[lisplab-cvs] r12 - src
Jørn Inge Vestgården
jivestgarden at common-lisp.net
Tue Apr 14 17:59:23 UTC 2009
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
More information about the lisplab-cvs
mailing list