From jivestgarden at common-lisp.net Tue Apr 14 17:58:37 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Tue, 14 Apr 2009 13:58:37 -0400 Subject: [lisplab-cvs] r11 - src Message-ID: Author: jivestgarden Date: Tue Apr 14 13:58:36 2009 New Revision: 11 Log: minor change Modified: src/level1-blas-real.lisp Modified: src/level1-blas-real.lisp ============================================================================== --- src/level1-blas-real.lisp (original) +++ src/level1-blas-real.lisp Tue Apr 14 13:58:36 2009 @@ -52,7 +52,6 @@ (truly-the type-blas-idx col) rows)))) - (defun (setf ref-blas-real-store) (value store row col rows) (setf (aref (truly-the type-blas-store store) (truly-the type-blas-idx From jivestgarden at common-lisp.net Tue Apr 14 17:59:23 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Tue, 14 Apr 2009 13:59:23 -0400 Subject: [lisplab-cvs] r12 - src Message-ID: Author: jivestgarden Date: Tue Apr 14 13:59:23 2009 New Revision: 12 Log: Some kind of finished but seems to be not usefull Modified: src/template.lisp Modified: src/template.lisp ============================================================================== --- src/template.lisp (original) +++ src/template.lisp Tue Apr 14 13:59:23 2009 @@ -1,30 +1,254 @@ -(in-package :lisplab) +(in-package :lisplab) ;; should not be part of lisplab package + +(defun 0elm (m) + (if (matrix? m) + (coerce 0 (element-type m)) + (coerce 0 (type-of m)))) (defclass template () ((symbol :initarg :symbol :accessor template-symbol :documentation "The variable") - ;; TODO some gensym symbol for dynamic symbol - #+nil (type + (dynamic-symbol ;;; TODO use this rather than a dynamic variant of the other + :initarg :dynamic-symbol + :accessor template-dynamic-symbol + :documentation "The dynamic variable") + (type :initarg :type :accessor template-type :documentation "The actual run-time type") )) +(defmethod print-object ((tl template) stream) + (print-unreadable-object (tl stream :type t :identity t) + (prin1 (template-symbol tl) stream))) + +(defgeneric create-template (type symbol &rest rest)) + +(defgeneric handle (what template code)) + +(defgeneric extra-let*s (template)) + +(defgeneric extra-declares (template)) + + +;;; Defaults + +(defmethod handle (what template code) code) + +(defmethod extra-let*s (template) nil) + +(defmethod extra-declares (template) nil) + +;;; Blas real templates + (defclass template-blas-real (template) ((store-symbol - :initform (gensym) + :initform (gensym "store") :accessor template-store-symbol - :documentation "Temp variable store") + :documentation "Temp variable for store") (rows-symbol - :initform (gensym) + :initform (gensym "rows") :accessor template-rows-symbol - :documentation "Temp variable store") + :documentation "Temp variable for rows") + (cols-symbol + :initform (gensym "cols") + :accessor template-cols-symbol + :documentation "Temp variable for columns") )) +(defmethod create-template ((type (eql 'blas-real)) + symbol &rest rest) + (make-instance 'template-blas-real :symbol symbol)) + +(defmethod handle ((what (eql 'mref)) (tl template-blas-real) code ) + (destructuring-bind (ref a i j) code + (if (eql a (template-symbol tl)) + (list 'ref-blas-real-store (template-store-symbol tl) i j (template-rows-symbol tl)) + code))) + +(defmethod handle ((what (eql 'rows)) (tl template-blas-real) code ) + (destructuring-bind (rows a) code + (if (eql a (template-symbol tl)) + (template-rows-symbol tl) + code))) + +(defmethod handle ((what (eql 'cols)) (tl template-blas-real) code) + (destructuring-bind (cols a) code + (if (eql a (template-symbol tl)) + (template-cols-symbol tl) + code))) + +(defmethod extra-let*s ((tl template-blas-real)) + (list `(,(template-store-symbol tl) (store ,(template-symbol tl))) + `(,(template-rows-symbol tl) (rows ,(template-symbol tl))) + `(,(template-cols-symbol tl) (cols ,(template-symbol tl))))) + +(defmethod extra-declares ((tl template-blas-real)) + (list `(blas-real ,(template-symbol tl)) + `((simple-array double-float (*)) ,(template-store-symbol tl)) + `(type-blas-idx ,(template-rows-symbol tl)) + `(type-blas-idx ,(template-cols-symbol tl)))) + +;;; Double floats + +(defclass template-double-float (template)()) + +(defmethod create-template ((type (eql 'double-float)) + symbol &rest rest) + (make-instance 'template-double-float :symbol symbol)) + +(defmethod extra-declares ((tl template-double-float)) + (list `(double-float ,(template-symbol tl)))) + + +;;;; The actual optimizations + +(defun handle-tree (tl code) + (if (consp code) + (let ((code2 (mapcar (lambda (code) (handle-tree tl code)) code))) + (handle (car code2) tl code2)) + code)) + +(defun handle-all (templates code) + (if templates + (handle-all (cdr templates) + (handle-tree (car templates) code)) + code)) + +(defun generate-code (syms vals code) + (let* ((templates (mapcar #'create-template + (mapcar #'type-of vals) + syms )) + (let*s (mapcan #'extra-let*s templates)) + (declares (mapcan #' extra-declares templates)) + (code2 (handle-all templates code))) + `(let* ,let*s + (declare , at declares) + , at code2))) + +(defmacro w/dynamic (args &body body) + "Optimized code, but without any structure information and anything +that should be otimized must be an argument" + (let ((run (gensym "run"))) + `(progv ',args (list , at args) + (let ((,run (generate-code + ',args + (list , at args) + ',body))) + (eval ,run))))) + + +(defun test-m* (A B) + (let* ((M (rows a)) + (N (cols b)) + (S (cols a)) + (c (create a 0 (list M N))) + (tmp 0.0)) + (w/dynamic (a b c tmp) + (dotimes (i (rows A)) + (dotimes (j (cols B)) + (setf tmp 0.0) + (dotimes (k (cols A)) + (incf tmp (* (mref a i k) (mref b k j)))) + (setf (mref c i j) tmp))) + c))) + +#+nil (defun test-m* (a b) + (let* ((M (rows a)) + (N (cols b)) + (S (cols a)) + (c (create a 0 (list M N))) + (tmp 0)) + (w/dynamic (a b c M N S) + (dotimes (i M) + (dotimes (j N) + #+nil (setf tmp 0) + (dotimes (k S) + (incf (mref C i j) (* (mref a i k) (mref b k j)))))) + c))) + + + + + + + + + + + + +#| + + +;; The parsing context + +(defclass context () + ((templates + :initarg :templates + :initform nil + :accessor context-templates + :documentation "The context") + #+nil (code + :initarg :code + :initform nil + :accessor context-code + :documentation "The code"))) + +(defmethod print-object ((c context) stream) + (print-unreadable-object (c stream :type t :identity t) + (dolist (tl (context-templates c)) + (format stream "~&~A" tl)))) + +(defgeneric push-template (context template)) + +(defmethod push-template ((c context) tl) + (setf (context-templates c) + (cons tl (context-templates c))) + tl) + +(defgeneric pop-template (context)) + +(defmethod pop-template ((c context)) + (let ((x (car (context-templates c)))) + (setf (context-templates c) + (cdr (context-templates c))) + x)) + + +#+nil (defgeneric optimize-context (template context)) + +;;; defaults + +(defmethod handle (what template code) nil) + +(defmethod handle-all (context code) + (if (consp code) + (progn + ;; TODO let a new kind of declare to update context + (let ((code2 (mapcar (lambda (c) + (handle-all context c)) + code))) + (dolist (tl (context-templates context)) + (let ((x (handle (car code2) tl code2))) + (if x (return-from handle-all x)))) + code2)) + code)) + +(defgeneric extra-declares (template)) + + + + + + + + + + -(defgeneric create-template (type symbol &rest rest )) (defgeneric apply-template (template code)) @@ -34,10 +258,6 @@ ;;;; Blas real templates -(defmethod create-template ((type (eql 'blas-real)) - symbol &rest rest) - (make-instance 'template-blas-real :symbol symbol)) - (defmethod make-template-declare-forms ((tl template-blas-real)) `((type type-blas-store ,(template-store-symbol tl) ) (type type-blas-idx ,(template-rows-symbol tl) ))) @@ -405,16 +625,12 @@ `(type ,store-type ,store-sym))) - -#| - -|# - - #+nil (defmacro defmat (name return-type args defs &body body) (let ((body2 (gensym))) `(defmethod ,name ,(defmat-parse-args args) (let ,defs (let ((body ',body)) (macrolet ((,body2 () `(progn , at body))) - (,body2)))))) ) \ No newline at end of file + (,body2)))))) ) + +|# \ No newline at end of file