Dear LISP hackers, yesterday, a colleague of mine caused quite some confusion on my side by showing to me a function he had written to calculate the system of positive roots of a semi-simple finite-dimensional Lie algebra (blah blah - does not matter). This is given as cartan->posroots-v1 in the attachment. I tried to make it fast by heeding the compiler's notes and giving additional type declarations (there are also a lot of consing-reduction techniques that can be applied, I know, and our current version has all of them); amazingly, when I gave CMUCL enough type info so that the function compiled without notes (see the -v2 variant), the resulting code turned out to be *slower* by a factor 2.
*What* is going on here? -- regards, [EMAIL PROTECTED] (o_ Thomas Fischbacher - http://www.cip.physik.uni-muenchen.de/~tf //\ (lambda (n) ((lambda (p q r) (p p q r)) (lambda (g x y) V_/_ (if (= x 0) y (g g (- x 1) (* x y)))) n 1)) (Debian GNU) -- Attached file included as plaintext by Listar -- -- File: cmucl.lisp -- Desc: 1 ;; perl-order 1-element push (defmacro ppush (li elem) `(push ,elem ,li)) (defmacro cav (assoc pos &rest rest) `(cdr (assoc ,pos ,assoc ,@rest))) (defmacro hv (hash key &rest rest) `(gethash ,key ,hash ,@rest)) (defmacro i+ (&rest args) `(the fixnum (+ ,@(mapcar #'(lambda (x) `(the fixnum ,x)) args)))) (defmacro i* (&rest args) `(the fixnum (* ,@(mapcar #'(lambda (x) `(the fixnum ,x)) args)))) (defmacro i- (&rest args) `(the fixnum (- ,@(mapcar #'(lambda (x) `(the fixnum ,x)) args)))) (defmacro i/ (&rest args) `(the fixnum (floor ,@(mapcar #'(lambda (x) `(the fixnum ,x)) args)))) (defmacro i= (&rest args) `(= ,@(mapcar #'(lambda (x) `(the fixnum ,x)) args))) (defmacro i< (&rest args) `(< ,@(mapcar #'(lambda (x) `(the fixnum ,x)) args))) (defmacro i<= (&rest args) `(<= ,@(mapcar #'(lambda (x) `(the fixnum ,x)) args))) (defmacro i> (&rest args) `(> ,@(mapcar #'(lambda (x) `(the fixnum ,x)) args))) (defmacro i>= (&rest args) `(>= ,@(mapcar #'(lambda (x) `(the fixnum ,x)) args))) (defmacro i/= (&rest args) `(/= ,@(mapcar #'(lambda (x) `(the fixnum ,x)) args))) (defmacro i1+ (x) `(the fixnum (1+ (the fixnum ,x)))) (defmacro i1- (x) `(the fixnum (1- (the fixnum ,x)))) (defmacro i-incf (x) `(setf ,x (i1+ ,x))) (defmacro i-decf (x) `(setf ,x (i1- ,x))) (defmacro i-mod (&rest args) `(the fixnum (mod ,@(mapcar #'(lambda (x) `(the fixnum ,x)) args)))) (defmacro i-dotimes (rangespec &rest body) (let ((var (car rangespec))) `(dotimes ,rangespec (declare (fixnum ,var)) ,@body))) (defun array*vector (arr vec) (declare (optimize (speed 3))) (let* ((rows (array-dimension arr 0)) (cols (array-dimension arr 1)) (result (make-array rows :element-type (array-element-type arr))) (elem0 (aref result 0))) (declare (fixnum rows cols)) (dotimes (row rows) (declare (fixnum row)) (labels ((traverse (sum col) (declare (fixnum col)) (if (i< col 0) (setf (aref result row) sum) (traverse (+ sum (* (aref arr row col) (aref vec col))) (i1- col))))) (traverse elem0 (i1- cols)))) result)) (defvar E8 `((:cartan . ,(make-array '(8 8) :element-type 'fixnum :initial-contents '(( 2 -1 0 0 0 0 0 0) (-1 2 -1 0 0 0 0 0) ( 0 -1 2 -1 0 0 0 0) ( 0 0 -1 2 -1 0 0 0) ( 0 0 0 -1 2 -1 0 -1) ( 0 0 0 0 -1 2 -1 0) ( 0 0 0 0 0 -1 2 0) ( 0 0 0 0 -1 0 0 2)))) (:rank . ,8))) (defvar B8 `((:cartan . ,(make-array '(8 8) :element-type 'fixnum :initial-contents '(( 2 -1 0 0 0 0 0 0) (-1 2 -1 0 0 0 0 0) ( 0 -1 2 -1 0 0 0 0) ( 0 0 -1 2 -1 0 0 0) ( 0 0 0 -1 2 -1 0 0) ( 0 0 0 0 -1 2 -1 0) ( 0 0 0 0 0 -1 2 -2) ( 0 0 0 0 0 0 -1 2)))) (:rank . ,8))) (defvar G2 `((:cartan . ,(make-array '(2 2) :element-type 'fixnum :initial-contents '(( 2 -3) (-1 2)))) (:rank . ,2))) (defvar F4 `((:cartan . ,(make-array '(4 4) :element-type 'fixnum :initial-contents '(( 2 -1 0 0) (-1 2 -2 0) ( 0 -1 2 -1) ( 0 0 -1 2)))) (:rank . ,4))) (defun Cartan->PosRoots-v1 (group) (declare (optimize (safety 0) (speed 3))) (let* ((cartan (cav group :cartan)) (rank (cav group :rank)) (pos-roots (make-hash-table :test 'equalp)) (last-roots '()) (levels '(0)) (num rank) ) ;; (i-dotimes (j rank) (let ((simp-root (make-array rank :initial-element 0))) (setf (aref simp-root j) 1) (setf (hv pos-roots simp-root) j) ;; (ppush simp-roots simp-root) (ppush last-roots simp-root))) ;; ;;(labels ((traverse (level) (do ((level 1 (i1+ level))) ((or (i<= num (car levels)) ;; (i> num 300) )) (ppush levels num) (let ((new-roots '())) (dolist (old-root (nreverse last-roots)) (let ((old-root-vee (array*vector cartan old-root))) (i-dotimes (j rank) (cond ;; Optimizalbe by first checking for (i< (...) 0) and, if not, then this complicated version ((i< (aref old-root-vee j) (labels ((traverse (older-root p) (i-decf (aref older-root j)) (cond ((hv pos-roots older-root) (traverse older-root (i1+ p))) (t p)))) (traverse (copy-seq old-root) 0))) (let ((new-root (copy-seq old-root))) (i-incf (aref new-root j)) (cond ((not (hv pos-roots new-root)) (i-incf num) (setf (hv pos-roots new-root) num) (ppush new-roots new-root)))))))));;dolist (setq last-roots new-roots)) ) ;; `((:rank . ,rank) (:cartan . ,cartan) (:pos-roots . ,pos-roots) (:levels . ,levels)))) (defun Cartan->PosRoots-v2 (group) (declare (optimize (safety 0) (speed 3))) (let* ((cartan (cav group :cartan)) (rank (cav group :rank)) (pos-roots (make-hash-table :test 'equalp)) (last-roots '()) (levels '(0)) (num rank) ) (declare (fixnum rank)) ;; (i-dotimes (j rank) (let ((simp-root (make-array rank :element-type 'fixnum :initial-element 0))) (setf (aref simp-root j) 1) (setf (hv pos-roots simp-root) j) ;; (ppush simp-roots simp-root) (ppush last-roots simp-root))) ;; ;;(labels ((traverse (level) (do ((level 1 (i1+ level))) ((or (i<= num (car levels)) ;; (i> num 300) )) (ppush levels num) (let ((new-roots '())) (dolist (old-root (nreverse last-roots)) (declare (type (simple-array fixnum (*)) old-root)) (let ((old-root-vee (array*vector cartan old-root))) (declare (type (simple-array fixnum (*)) old-root-vee)) (i-dotimes (j rank) (cond ;; Optimizalbe by first checking for (i< (...) 0) and, if not, then this complicated version ((i< (aref old-root-vee j) (labels ((traverse (older-root p) (declare (type (simple-array fixnum (*)) older-root)) (i-decf (aref older-root j)) (cond ((hv pos-roots older-root) (traverse older-root (i1+ p))) (t p)))) (traverse (copy-seq old-root) 0))) (let ((new-root (copy-seq old-root))) (i-incf (aref new-root j)) (cond ((not (hv pos-roots new-root)) (i-incf num) (setf (hv pos-roots new-root) num) (ppush new-roots new-root)))))))));;dolist (setq last-roots new-roots)) ) ;; `((:rank . ,rank) (:cartan . ,cartan) (:pos-roots . ,pos-roots) (:levels . ,levels)))) #| * (time (i-dotimes (j 1000) (cartan->posroots-v1 e8))) Compiling LAMBDA NIL: Compiling Top-Level Form: Evaluation took: 5.18 seconds of real time 5.01 seconds of user run time 0.16 seconds of system run time [Run times include 0.08 seconds GC run time] 0 page faults and 84968648 bytes consed. NIL * (time (i-dotimes (j 1000) (cartan->posroots-v2 e8))) Compiling LAMBDA NIL: Compiling Top-Level Form: Evaluation took: 10.26 seconds of real time 10.12 seconds of user run time 0.16 seconds of system run time [Run times include 0.07 seconds GC run time] 0 page faults and 103899024 bytes consed. NIL |#
