- movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp
by Frode Vatvedt Fjeld 15 Feb '04

15 Feb '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19892 Modified Files: los-closette.lisp Log Message: Added discriminator functions for map111, which cannot be handled by map1111 as I thought before. Date: Sun Feb 15 08:16:56 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.2 movitz/losp/muerte/los-closette.lisp:1.3 --- movitz/losp/muerte/los-closette.lisp:1.2 Mon Jan 19 06:23:46 2004 +++ movitz/losp/muerte/los-closette.lisp Sun Feb 15 08:16:56 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.3 2004/02/15 13:16:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -29,7 +29,7 @@ ,(canonicalize-direct-superclasses direct-superclasses) :direct-slots ,(canonicalize-direct-slots direct-slots name env) - ,@(canonicalize-defclass-options options env))))) + ,@(canonicalize-defclass-options options env name))))) (defmacro defgeneric (function-name lambda-list &rest options) `(eval-when (:compile-toplevel) @@ -591,6 +591,20 @@ gf (length (std-gf-classes-to-emf-table gf)))) (apply emfun args))) +(defun cached-lookup-failed-map111 (gf &rest args) + (declare (dynamic-extent args)) + (multiple-value-bind (emfun active-specializers) + (slow-method-lookup gf args (mapcar #'class-of args)) + (push (list* (first active-specializers) + (second active-specializers) + (third active-specializers) + emfun) + (std-gf-classes-to-emf-table gf)) + (when (< 4 (length (std-gf-classes-to-emf-table gf))) + (warn "method cache size for ~S: ~D" + gf (length (std-gf-classes-to-emf-table gf)))) + (apply emfun args))) + (defun cached-lookup-failed-map1111 (gf &rest args) (declare (dynamic-extent args)) (multiple-value-bind (emfun active-specializers) @@ -712,7 +726,7 @@ (let ((class0 (class-of arg0)) (class1 (class-of arg1))) (dolist (entry (std-gf-classes-to-emf-table gf) - (apply 'cached-lookup-failed-map111 gf arg0 arg1 optional-args)) + (apply 'cached-lookup-failed-map11 gf arg0 arg1 optional-args)) (let ((e entry)) (when (and (eq class0 (pop e)) (eq class1 (pop e))) @@ -741,8 +755,25 @@ (eq class2 (pop e))) (return (apply e arg0 arg1 arg2 optional-args))))))))) +(defun discriminating-function-map111 (&edx gf arg0 arg1 arg2 &rest optional-args) + (declare (dynamic-extent optional-args)) + (let ((es-table (std-gf-eql-specializer-table gf))) + (macrolet ((specializer-of (arg) + `(let ((es (pop es-table))) + (or (and es (gethash ,arg es)) + (class-of ,arg))))) + (let ((specializer0 (specializer-of arg0)) + (specializer1 (specializer-of arg1)) + (specializer2 (specializer-of arg2))) + (dolist (entry (std-gf-classes-to-emf-table gf) + (apply 'cached-lookup-failed-map111 gf arg0 arg1 arg2 optional-args)) + (let ((e entry)) + (when (and (eq specializer0 (pop e)) + (eq specializer1 (pop e)) + (eq specializer2 (pop e))) + (return (apply e arg0 arg1 arg2 optional-args))))))))) + (defun discriminating-function-map1111 (&edx gf arg0 arg1 arg2 arg3 &rest optional-args) - "This discriminator will work for all GFs with 4 required arguments or fewer." (declare (dynamic-extent optional-args)) (let ((es-table (std-gf-eql-specializer-table gf))) (macrolet ((specializer-of (arg) @@ -827,7 +858,11 @@ ((and (not eqls-p) (= specializer-bitmap (logand #b101 specializer-bitmap))) #'discriminating-function-map101-no-eqls) - ((= specializer-bitmap (logand #b1111 specializer-bitmap)) + ((and (<= 3 (std-gf-num-required-arguments gf)) + (= specializer-bitmap (logand #b111 specializer-bitmap))) + #'discriminating-function-map111) + ((and (<= 4 (std-gf-num-required-arguments gf)) + (= specializer-bitmap (logand #b1111 specializer-bitmap))) #'discriminating-function-map1111) (t (warn "Defaulting map ~b for ~S~@[ with eql-specializers~]." specializer-bitmap gf eqls-p)

1 0

[movitz-cvs] CVS update: movitz/special-operators.lisp
by Frode Vatvedt Fjeld 14 Feb '04

14 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv21632 Modified Files: special-operators.lisp Log Message: Ensure inlined-not returns correct type: either boolean, null, or (eql t). Date: Sat Feb 14 18:46:56 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.12 movitz/special-operators.lisp:1.13 --- movitz/special-operators.lisp:1.12 Sat Feb 14 10:18:54 2004 +++ movitz/special-operators.lisp Sat Feb 14 18:46:56 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.12 2004/02/14 15:18:54 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.13 2004/02/14 23:46:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -622,12 +622,21 @@ ((member (operator result-mode) '(:push)) (values :eax nil)) (t (values result-mode nil))) - (compiler-values-bind (&all not-values &returns not-returns &code not-code) + (compiler-values-bind (&all not-values &returns not-returns &code not-code &type not-type) (compiler-call #'compile-form-unprotected :defaults forward :form x :result-mode not-result-mode) - (setf (not-values :producer) (list :not (not-values :producer))) + (setf (not-values :producer) + (list :not (not-values :producer))) + (let ((not-type (type-specifier-primary not-type))) + (setf (not-values :type) + (cond + ((movitz-subtypep not-type 'null) + '(eql t)) + ((movitz-subtypep not-type '(not null)) + 'null) + (t 'boolean)))) ;; (warn "res: ~S" result-mode-inverted-p) (cond ((and result-mode-inverted-p @@ -644,7 +653,7 @@ :code code))) ((not result-mode-inverted-p) ;; We must invert returns-mode - (case (operator not-returns) + (case (operator not-returns) (#.(append +boolean-modes+ '(:boolean-branch-on-true :boolean-branch-on-false)) (compiler-values (not-values) :returns (complement-boolean-result-mode not-returns)))

1 0

[movitz-cvs] CVS update: movitz/compiler-types.lisp
by Frode Vatvedt Fjeld 14 Feb '04

14 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv1074 Modified Files: compiler-types.lisp Log Message: Fixed buggy encoded-emptyp. Date: Sat Feb 14 17:47:25 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.7 movitz/compiler-types.lisp:1.8 --- movitz/compiler-types.lisp:1.7 Sat Feb 14 17:11:36 2004 +++ movitz/compiler-types.lisp Sat Feb 14 17:47:25 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.7 2004/02/14 22:11:36 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.8 2004/02/14 22:47:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -472,7 +472,12 @@ (assert (= 2 (length type-specifier))) (multiple-value-bind (code integer-range members include complement) (type-specifier-encode (second type-specifier)) - (values code integer-range members include (not complement)))) + (cond + ((encoded-allp code integer-range members include complement) + (type-specifier-encode nil)) + ((encoded-emptyp code integer-range members include complement) + (type-specifier-encode t)) + (t (values code integer-range members include (not complement)))))) (integer (flet ((integer-limit (s n) (let ((x (if (nthcdr n s) @@ -523,8 +528,14 @@ If it isn't, also return wether we _know_ it isn't empty." (let ((x (and (= 0 code) (not integer-range) (null members) t))) (cond - ((null include) - (values (if complement (not x) x) t)) + ((and x (null include) (not complement)) + (values t t)) + ((and (null include) complement) + (cond + ((encoded-allp code integer-range members include nil) + (warn "Seeing an encoded (not t), should be ()") + (values t t)) + (t (values nil t)))) ((not (null include)) (values nil nil)))))

1 0

[movitz-cvs] CVS update: movitz/compiler-types.lisp
by Frode Vatvedt Fjeld 14 Feb '04

14 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv27008 Modified Files: compiler-types.lisp Log Message: Added encoded-type-singleton, and small changes to encoded-subtypep. Date: Sat Feb 14 17:11:36 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.6 movitz/compiler-types.lisp:1.7 --- movitz/compiler-types.lisp:1.6 Sat Feb 14 08:56:19 2004 +++ movitz/compiler-types.lisp Sat Feb 14 17:11:36 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.6 2004/02/14 13:56:19 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.7 2004/02/14 22:11:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -56,47 +56,8 @@ (defun type-specifier-singleton (type-specifier) "If type-specifier is a singleton type, return a singleton list with the single member of <type-specifier>." - (let ((old-result (cond - ((eq 'null type-specifier) - ;; The type NULL is a singleton. - (list (movitz-read nil))) - ((listp type-specifier) - (case (car type-specifier) - (eql - (cdr type-specifier)) - (member - (when (= 1 (length (cdr type-specifier))) - (cdr type-specifier))) - (integer - (when (and (integerp (second type-specifier)) - (integerp (third type-specifier)) - (= (second type-specifier) - (third type-specifier))) - (second type-specifier))))))) - (new-result - (multiple-value-bind (code intscope members include complement) - (type-specifier-encode type-specifier) - (cond - ((or complement include (not (= 0 code))) - nil) - ((= 1 (length members)) - members) - ((and (= 1 (length intscope)) - (caar intscope) - (eql (caar intscope) - (cdar intscope))) - (list (movitz-read (caar intscope)))))))) - (check-type old-result list) - (check-type new-result list) - (cond - ((and old-result new-result) - (assert (movitz-eql (car old-result) (car new-result))) - new-result) - ((and (not old-result) (not new-result)) - nil) - (t (warn "ts-singleton different result: old ~S, new: ~S" - old-result new-result) - new-result)))) + (multiple-value-call #'encoded-type-singleton + (type-specifier-encode type-specifier))) ;;; @@ -444,7 +405,16 @@ (union members0 members1 :test #'movitz-eql)) (union include0 include1 :test #'equal) nil))) - (t (error "Not implemented")))) + ((and (not complement0) complement1) + (values code0 + integer-range0 + members0 + (cons (encoded-type-decode code1 integer-range1 members1 include1 complement1) + include0) + nil)) + (t (error "Not implemented: ~S or ~S" + (encoded-type-decode code0 integer-range0 members0 include0 complement0) + (encoded-type-decode code1 integer-range1 members1 include1 complement1))))) (defun type-specifier-encode (type-specifier) @@ -583,13 +553,13 @@ ((encoded-allp code1 integer-range1 members1 include1 complement1) ;; type1 is t. (result-is t t)) - ((and (encoded-emptyp code1 integer-range1 members1 include1 complement1) - (not (encoded-emptyp code0 integer-range0 members0 include0 complement0))) - ;; type1 is nil and type0 isn't. - (result-is nil t)) ((encoded-emptyp code0 integer-range0 members0 include0 complement0) ;; type0 is nil, which is a subtype of anything. (result-is t t)) + ((and (encoded-emptyp code1 integer-range1 members1 include1 complement1) + #+ignore (not (encoded-emptyp code0 integer-range0 members0 include0 complement0))) + ;; type1 is nil and type0 isn't. + (result-is nil t)) ((and (encoded-allp code0 integer-range0 members0 include0 complement0) (multiple-value-bind (all1 confident) (encoded-allp code1 integer-range1 members1 include1 complement1) @@ -611,14 +581,29 @@ ((:unknown) (result-is nil nil)) ((t) nil))) - (when include0 - (result-is nil nil)) - (result-is t t)) + (if include0 + (result-is nil nil) + (result-is t t))) ((and complement0 complement1) (encoded-subtypep code1 integer-range1 members1 include1 nil code0 integer-range0 members0 include0 nil)) (t (result-is nil nil)))))) - + +(defun encoded-type-singleton (code intscope members include complement) + "If the encoded type is a singleton, return that element in a list." + (cond + ((or complement include (not (= 0 code))) + nil) + ((= 1 (length members)) + members) + ((and (= 1 (length intscope)) + (caar intscope) + (eql (caar intscope) + (cdar intscope))) + (list (movitz-read (caar intscope)))) + ((and (null members) (null intscope)) + (warn "Not singleton, nulloton.")))) + (defun movitz-subtypep (type1 type2) "Compile-time subtypep." (multiple-value-call #'encoded-subtypep

1 0

[movitz-cvs] CVS update: movitz/special-operators-cl.lisp
by Frode Vatvedt Fjeld 14 Feb '04

14 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv12122 Modified Files: special-operators-cl.lisp Log Message: For the LET compiler, one subtle change that shortens many functions by a few bytes, and one bug-fix regarding losing the side-effects of binding's init-forms in some cases (which were never actually occurred in the current losp code). Date: Sat Feb 14 12:33:42 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.10 movitz/special-operators-cl.lisp:1.11 --- movitz/special-operators-cl.lisp:1.10 Fri Feb 13 17:08:33 2004 +++ movitz/special-operators-cl.lisp Sat Feb 14 12:33:40 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.10 2004/02/13 22:08:33 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.11 2004/02/14 17:33:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -137,131 +137,142 @@ :env local-env)))) (compiler-values-bind (&all body-values &code body-code &returns body-returns) (compile-body) - (cond - ;; Is this (let ((#:foo <form>)) (setq bar #:foo)) ? - ;; If so, make it into (setq bar <form>) - ((and (= 1 (length binding-var-codes)) - (typep (movitz-binding (caar binding-var-codes) local-env nil) - 'lexical-binding) - (instruction-is (first body-code) :load-lexical) - (instruction-is (second body-code) :store-lexical) - (null (cddr body-code)) - (eq (movitz-binding (caar binding-var-codes) local-env nil) ; same binding? - (second (first body-code))) - (eq (third (first body-code)) ; same register? - (third (second body-code)))) - (let ((dest-binding (second (second body-code)))) - (check-type dest-binding lexical-binding) - (compiler-call #'compile-form - :forward all - :result-mode dest-binding - :form (second (first binding-var-codes))))) - #+ignore - ((and (= 1 (length binding-var-codes)) - (typep (movitz-binding (caar binding-var-codes) local-env nil) - 'lexical-binding) - (instruction-is (first body-code) :load-lexical) - (not (code-uses-binding-p (rest body-code) (second (first body-code)) - :load t :store nil)) - (eq (movitz-binding (caar binding-var-codes) local-env nil) ; same binding? - (second (first body-code)))) - (let ((tmp-binding (second (first body-code)))) - (print-code 'body body-code) - (break "Yuhu: tmp ~S" tmp-binding))) - (t (let ((code (append - (loop - for ((var init-form init-code functional-p type init-register) - . rest-codes) - on binding-var-codes - as binding = (movitz-binding var local-env nil) - ;; for bb in binding-var-codes - ;; do (warn "bind: ~S" bb) - do (assert type) - (assert (not (binding-lended-p binding))) - appending - (cond - ;; #+ignore - ((and (typep binding 'located-binding) - (not (binding-lended-p binding)) - (= 1 (length init-code)) - (eq :load-lexical (first (first init-code))) - (let* ((target-binding (second (first init-code)))) - (and (typep target-binding 'lexical-binding) - (eq (binding-funobj binding) - (binding-funobj target-binding)) - (or (and (not (code-uses-binding-p body-code - binding - :load nil - :store t)) - (not (code-uses-binding-p body-code - target-binding - :load nil - :store t))) - ;; This is the best we can do now to determine - ;; if target-binding is ever used again. - (and (eq result-mode :function) - (not (code-uses-binding-p body-code - target-binding - :load t - :store t)) - (notany (lambda (code) - (code-uses-binding-p (third code) - target-binding - :load t - :store t)) - rest-codes)))))) - ;; replace read-only lexical binding with the outer lexical binding - ;; (warn "replace ~S with outer ~S" var (second (first init-code))) - (change-class binding 'forwarding-binding - :target-binding (second (first init-code))) - nil) - ((and (typep binding 'located-binding) - (type-specifier-singleton type) - (not (code-uses-binding-p body-code binding :load nil :store t))) - ;; replace read-only lexical binding with - ;; side-effect-free form - #+ignore (warn "Constant binding: ~S => ~S => ~S" - (binding-name binding) - init-form - (car (type-specifier-singleton type))) - (when (code-uses-binding-p body-code binding :load t) - (setf recompile-body-p t)) - (change-class binding 'constant-object-binding - :object (car (type-specifier-singleton type))) - (if functional-p - nil ; only inject code if it's got side-effects. - (compiler-call #'compile-form-unprotected - :env init-env - :defaults all - :form init-form - :result-mode :ignore - :modify-accumulate let-modifies))) - ((typep binding 'lexical-binding) - (let ((init (type-specifier-singleton - (type-specifier-primary type)))) - (if (and init (eq *movitz-nil* (car init))) - `((:init-lexvar ,binding - :init-with-register :edi - :init-with-type null)) - (append `((:init-lexvar ,binding)) - init-code - `((:store-lexical ,binding ,init-register - :type ,(type-specifier-primary type))))))) - (t init-code))) - (when (plusp (num-specials local-env)) - `((:locally (:movl :esp (:edi (:edi-offset dynamic-env)))))) - (if (not recompile-body-p) - body-code - (progn #+ignore (warn "recompile..") - (compile-body))) - (when (plusp (num-specials local-env)) - `((:leal (:esp ,(+ -4 (* 16 (num-specials local-env)))) :esp) - (:locally (:popl (:edi (:edi-offset dynamic-env))))))))) - (compiler-values (body-values) - :returns body-returns - :producer (default-compiler-values-producer) - :modifies let-modifies - :code code))))))))))) +;;; (print-code 'body body-code) + (let ((first-binding (movitz-binding (caar binding-var-codes) local-env nil))) + (cond + ;; Is this (let ((#:foo <form>)) (setq bar #:foo)) ? + ;; If so, make it into (setq bar <form>) + ((and (= 1 (length binding-var-codes)) + (typep first-binding 'lexical-binding) + (instruction-is (first body-code) :load-lexical) + (instruction-is (second body-code) :store-lexical) + (null (cddr body-code)) + (eq first-binding ; same binding? + (second (first body-code))) + (eq (third (first body-code)) ; same register? + (third (second body-code)))) + (let ((dest-binding (second (second body-code)))) + (check-type dest-binding lexical-binding) + (compiler-call #'compile-form + :forward all + :result-mode dest-binding + :form (second (first binding-var-codes))))) + #+ignore + ((and (= 1 (length binding-var-codes)) + (typep (movitz-binding (caar binding-var-codes) local-env nil) + 'lexical-binding) + (member (movitz-binding (caar binding-var-codes) local-env nil) + (find-read-bindings (first body-code))) + (not (code-uses-binding-p (rest body-code) (second (first body-code)) + :load t :store nil))) + (let ((tmp-binding (second (first body-code)))) + (print-code 'body body-code) + (break "Yuhu: tmp ~S" tmp-binding) + + )) + (t (let ((code (append + (loop + for ((var init-form init-code functional-p type init-register) + . rest-codes) + on binding-var-codes + as binding = (movitz-binding var local-env nil) + ;; for bb in binding-var-codes + ;; do (warn "bind: ~S" bb) + do (assert type) + (assert (not (binding-lended-p binding))) + appending + (cond + ;; #+ignore + ((and (typep binding 'located-binding) + (not (binding-lended-p binding)) + (= 1 (length init-code)) + (eq :load-lexical (first (first init-code))) + (let* ((target-binding (second (first init-code)))) + (and (typep target-binding 'lexical-binding) + (eq (binding-funobj binding) + (binding-funobj target-binding)) + (or (and (not (code-uses-binding-p body-code + binding + :load nil + :store t)) + (not (code-uses-binding-p body-code + target-binding + :load nil + :store t))) + ;; This is the best we can do now to determine + ;; if target-binding is ever used again. + (and (eq result-mode :function) + (not (code-uses-binding-p body-code + target-binding + :load t + :store t)) + (notany (lambda (code) + (code-uses-binding-p (third code) + target-binding + :load t + :store t)) + rest-codes)))))) + ;; replace read-only lexical binding with the outer lexical binding + ;; (warn "replace ~S with outer ~S" var (second (first init-code))) + (change-class binding 'forwarding-binding + :target-binding (second (first init-code))) + nil) + ((and (typep binding 'located-binding) + (type-specifier-singleton type) + (not (code-uses-binding-p body-code binding :load nil :store t))) + ;; replace read-only lexical binding with + ;; side-effect-free form + #+ignore (warn "Constant binding: ~S => ~S => ~S" + (binding-name binding) + init-form + (car (type-specifier-singleton type))) + (when (code-uses-binding-p body-code binding :load t) + (setf recompile-body-p t)) + (change-class binding 'constant-object-binding + :object (car (type-specifier-singleton type))) + (if functional-p + nil ; only inject code if it's got side-effects. + (compiler-call #'compile-form-unprotected + :env init-env + :defaults all + :form init-form + :result-mode :ignore + :modify-accumulate let-modifies))) + ((typep binding 'lexical-binding) + (let ((init (type-specifier-singleton + (type-specifier-primary type)))) + (if (and init (eq *movitz-nil* (car init))) + (append (if functional-p + nil + (compiler-call #'compile-form-unprotected + :env init-env + :defaults all + :form init-form + :result-mode :ignore + :modify-accumulate let-modifies)) + `((:init-lexvar ,binding + :init-with-register :edi + :init-with-type null))) + (append init-code + `((:init-lexvar + ,binding + :init-with-register ,init-register + :init-with-type ,(type-specifier-primary type))))))) + (t init-code))) + (when (plusp (num-specials local-env)) + `((:locally (:movl :esp (:edi (:edi-offset dynamic-env)))))) + (if (not recompile-body-p) + body-code + (progn #+ignore (warn "recompile..") + (compile-body))) + (when (plusp (num-specials local-env)) + `((:leal (:esp ,(+ -4 (* 16 (num-specials local-env)))) :esp) + (:locally (:popl (:edi (:edi-offset dynamic-env))))))))) + (compiler-values (body-values) + :returns body-returns + :producer (default-compiler-values-producer) + :modifies let-modifies + :code code)))))))))))) (define-special-operator symbol-macrolet (&all forward &form form &env env &funobj funobj) (destructuring-bind (symbol-expansions &body declarations-and-body)

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by Frode Vatvedt Fjeld 14 Feb '04

14 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv8428 Modified Files: compiler.lisp Log Message: Minor edits, mostly related to type-inference. Date: Sat Feb 14 10:44:32 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.25 movitz/compiler.lisp:1.26 --- movitz/compiler.lisp:1.25 Fri Feb 13 17:05:04 2004 +++ movitz/compiler.lisp Sat Feb 14 10:44:32 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.25 2004/02/13 22:05:04 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.26 2004/02/14 15:44:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -357,7 +357,11 @@ (cond ((typep binding 'function-argument) (setf (type-analysis-encoded-type analysis) - (multiple-value-list (type-specifier-encode t)))) + (multiple-value-list + (type-specifier-encode (etypecase binding + (rest-function-argument 'list) + (supplied-p-function-argument 'boolean) + (function-argument t)))))) ((and (consp type) (eq 'binding-type (car type))) (let ((target-binding (binding-target (cadr type)))) (cond @@ -437,11 +441,17 @@ (type-analysis-binding-types analysis)) (setf (binding-store-type binding) (type-analysis-encoded-type analysis)) - #+ignore - (unless (apply #'encoded-allp (type-analysis-encoded-type analysis)) - (warn "Type: ~A => ~A" - (binding-name binding) - (apply #'encoded-type-decode (type-analysis-encoded-type analysis))))) + (when (or #+ignore (not (apply #'encoded-allp (type-analysis-encoded-type analysis))) + (multiple-value-call #'encoded-subtypep + (values-list (type-analysis-encoded-type analysis)) + (type-specifier-encode 'list))) + #+ignore + (warn "Type: ~S => ~A (~A)" + binding + (apply #'encoded-type-decode (type-analysis-encoded-type analysis)) + (multiple-value-call #'encoded-subtypep + (values-list (type-analysis-encoded-type analysis)) + (type-specifier-encode 'list))))) binding-usage)))) toplevel-funobj) @@ -494,9 +504,8 @@ (let ((store-binding (find-written-binding-and-type instruction))) (when store-binding (process-binding funobj store-binding '(:read)))) - (let ((load-binding (find-read-bindings instruction))) - (when load-binding - (process-binding funobj load-binding '(:read)))) + (dolist (load-binding (find-read-bindings instruction)) + (process-binding funobj load-binding '(:read))) (case (car instruction) (:call-lexical (process-binding funobj (second instruction) '(:call))) @@ -1167,7 +1176,7 @@ (declare (special *default-load-priority*)) (with-simple-restart (continue "Skip Movitz compilation of ~S." path) (with-retries-until-true (retry "Restart Movitz compilation of ~S." path) - (warn "Compiling ~A.." path) + ;; (warn "Compiling ~A.." path) (let* ((muerte.cl::*compile-file-pathname* path) (*package* (find-package :muerte)) (funobj (make-instance 'movitz-funobj-pass1 @@ -2423,9 +2432,8 @@ (incf (getf p :lended-count 0)) (setf (getf p :dynamic-extent-p) (and (getf p :dynamic-extent-p t) dynamic-extent-p)))))) - (let ((load-binding (find-read-bindings instruction))) - (when load-binding - (take-note-of-binding load-binding))) + (mapcar #'take-note-of-binding + (find-read-bindings instruction)) (let ((store-binding (find-written-binding-and-type instruction))) (when store-binding (take-note-of-binding store-binding t))) @@ -2579,9 +2587,9 @@ (dolist (instruction code) (when (consp instruction) (let ((x (or (when load - (let ((load-binding (find-read-bindings instruction))) - (when load-binding - (binding-eql binding load-binding)))) + (some (lambda (read-binding) + (binding-eql read-binding binding)) + (find-read-bindings instruction))) (when store (let ((store-binding (find-written-binding-and-type instruction))) (when store-binding @@ -5174,7 +5182,9 @@ (let* ((operator (car extended-instruction)) (finder (gethash operator *extended-code-find-read-binding*))) (when finder - (funcall finder extended-instruction))))) + (let ((result (funcall finder extended-instruction))) + (check-type result list "a list of read bindings") + result))))) (defvar *extended-code-find-write-binding-and-type* (make-hash-table :test #'eq)) @@ -5235,6 +5245,15 @@ (binding `(binding-type ,binding)))) +(defun binding-store-subtypep (binding type-specifier) + "Is type-specifier a subtype of all values ever stored to binding? + (Assuming analyze-bindings has put this information into binding-store-type.)" + (if (not (binding-store-type binding)) + nil + (multiple-value-call #'encoded-subtypep + (values-list (binding-store-type binding)) + (type-specifier-encode type-specifier)))) + ;;;;;;; ;;;;;;; Extended-code handlers ;;;;;;; @@ -5251,7 +5270,7 @@ (define-find-read-bindings :load-lexical (source destination &key &allow-other-keys) (declare (ignore destination)) (check-type source binding) - source) + (list source)) (define-extended-code-expander :load-lexical (instruction funobj frame-map) (destructuring-bind (source destination &key shared-reference-p tmp-register protect-registers) @@ -5272,7 +5291,7 @@ (define-find-read-bindings :lmove (source destination) (declare (ignore destination)) - (values source)) + (list source)) ;;;;;;;;;;;;;;;;;; Store-lexical @@ -5286,7 +5305,7 @@ (define-find-read-bindings :store-lexical (destination source &key &allow-other-keys) (declare (ignore destination)) (when (typep source 'binding) - source)) + (list source))) (define-extended-code-expander :store-lexical (instruction funobj frame-map) (destructuring-bind (destination source &key shared-reference-p type) @@ -5338,18 +5357,27 @@ ;;;;;;;;;;;;;;;;;; car +(define-find-read-bindings :car (x dst &key protect-registers) + (declare (ignore dst protect-registers)) + (when (typep x 'binding) + (list x))) (define-extended-code-expander :car (instruction funobj frame-map) - (declare (ignore funobj frame-map)) + (warn "CAR: ~S" instruction) (destructuring-bind (x dst) (cdr instruction) (assert (member dst '(:eax :ebx :ecx :edx))) (etypecase x (binding - `((:load-lexical ,x :eax) - (:call (:edi ,(global-constant-offset 'fast-car))) - ,@(when (not (eq dst :eax)) - `((:movl :eax ,dst))))) + (let* ((binding (ensure-local-binding (binding-target x) funobj))) + (cond + ((binding-store-subtypep binding 'list) + `(,@(make-load-lexical binding dst funobj nil frame-map) + (:movl (,dst -1) ,dst))) + (t `(,@(make-load-lexical binding dst funobj nil frame-map) + (:call (:edi ,(global-constant-offset 'fast-car))) + ,@(when (not (eq dst :eax)) + `((:movl :eax ,dst)))))))) (symbol (append (case x (:eax @@ -5370,8 +5398,8 @@ (values binding 'integer))) (define-find-read-bindings :incf-lexvar (binding delta &key protect-registers) - (declare (ignore delta protect-registers)) - nil #+ignore binding) + (declare (ignore delta protect-registers binding)) + nil) (define-extended-code-expander :incf-lexvar (instruction funobj frame-map) (destructuring-bind (binding delta &key protect-registers) @@ -5385,18 +5413,13 @@ ((and binding-type location (not (binding-lended-p binding)) - (multiple-value-call #'encoded-subtypep - (values-list (binding-store-type binding)) - (type-specifier-encode 'integer))) + (binding-store-subtypep binding 'integer)) ;; This is an optimized incf that doesn't have to do type-checking. (check-type location (integer 1 *)) `((:addl ,(* delta +movitz-fixnum-factor+) (:ebp ,(stack-frame-offset location))) (:into))) - ((and binding-type - (multiple-value-call #'encoded-subtypep - (values-list (binding-store-type binding)) - (type-specifier-encode 'integer))) + ((binding-store-subtypep binding 'integer) (let ((register (chose-free-register protect-registers))) `(,@(make-load-lexical (ensure-local-binding binding funobj) register funobj nil frame-map

1 0

[movitz-cvs] CVS update: movitz/special-operators.lisp
by Frode Vatvedt Fjeld 14 Feb '04

14 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv10112 Modified Files: special-operators.lisp Log Message: Added an experimental macro for inline assembly, :lexical-binding. Date: Sat Feb 14 10:18:54 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.11 movitz/special-operators.lisp:1.12 --- movitz/special-operators.lisp:1.11 Fri Feb 13 05:39:37 2004 +++ movitz/special-operators.lisp Sat Feb 14 10:18:54 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.11 2004/02/13 10:39:37 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.12 2004/02/14 15:18:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -560,6 +560,13 @@ (destructuring-bind (var reg &key (type t)) (cdr expr) `((:store-lexical ,(movitz-binding var env) ,reg :type ,type))))) + (setf (assembly-macro-expander :lexical-binding amenv) + (lambda (expr) + (destructuring-bind (var) + (cdr expr) + (let ((binding (movitz-binding var env))) + (check-type binding lexical-binding) + (list binding))))) (let ((code (assembly-macroexpand inline-asm amenv))) (assert (not (and (not side-effects) (tree-search code '(:store-lexical))))

1 0

[movitz-cvs] CVS update: movitz/compiler-types.lisp
by Frode Vatvedt Fjeld 14 Feb '04

14 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv4007 Modified Files: compiler-types.lisp Log Message: Improved member-type-encode to ensure that member objects are proper movitz-objects. Date: Sat Feb 14 08:56:19 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.5 movitz/compiler-types.lisp:1.6 --- movitz/compiler-types.lisp:1.5 Thu Feb 12 12:51:41 2004 +++ movitz/compiler-types.lisp Sat Feb 14 08:56:19 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.5 2004/02/12 17:51:41 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.6 2004/02/14 13:56:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -536,15 +536,16 @@ (multiple-value-bind (code integer-range members include complement) (type-specifier-encode nil) (dolist (x member-objects) - (multiple-value-setq (code integer-range members include complement) - (multiple-value-call #'encoded-types-or - code integer-range members include complement - (etypecase x - (movitz-fixnum - (type-values () :integer-range (make-numscope (movitz-fixnum-value x) - (movitz-fixnum-value x)))) - (movitz-object - (type-values () :members (list x))))))) + (let ((member (movitz-read x))) + (multiple-value-setq (code integer-range members include complement) + (multiple-value-call #'encoded-types-or + code integer-range members include complement + (etypecase member + (movitz-fixnum + (type-values () :integer-range (make-numscope (movitz-fixnum-value member) + (movitz-fixnum-value member)))) + (movitz-object + (type-values () :members (list member)))))))) (values code integer-range members include complement))) (defun encoded-emptyp (code integer-range members include complement)

1 0

[movitz-cvs] CVS update: movitz/load.lisp
by Frode Vatvedt Fjeld 13 Feb '04

13 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv20512 Modified Files: load.lisp Log Message: Added some cruft to make LW personal-edition sort-of build movitz. I was able to run (create-image), and almost (dump-image) too. A non-restricted LW would stand a good chance of working, I think, but I can't test that. Date: Fri Feb 13 17:17:42 2004 Author: ffjeld Index: movitz/load.lisp diff -u movitz/load.lisp:1.8 movitz/load.lisp:1.9 --- movitz/load.lisp:1.8 Tue Feb 10 13:06:22 2004 +++ movitz/load.lisp Fri Feb 13 17:17:41 2004 @@ -6,16 +6,26 @@ ;;;; For distribution policy, see the accompanying file COPYING. ;;;; ;;;; Filename: load.lisp -;;;; Description: +;;;; Description: Load the Movitz development system. ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Jan 15 18:40:58 2004 ;;;; -;;;; $Id: load.lisp,v 1.8 2004/02/10 18:06:22 ffjeld Exp $ +;;;; $Id: load.lisp,v 1.9 2004/02/13 22:17:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (in-package :cl-user) +#+lispworks-personal-edition (progn + (dbg::clear-all-source-level-debugging) + (hcl:toggle-source-debugging nil) + (compiler::clear-xref-info t) + (setf compiler:*source-level-debugging* nil + compiler:*load-xref-info* nil + compiler:*produce-xref-info* nil) + (proclaim '(optimize (space 3) (speed 0) + (debug 0) (compilation-speed 3)))) + (load (compile-file #p"../binary-types/binary-types")) (let ((*default-pathname-defaults* (merge-pathnames #p"../ia-x86/"))) @@ -61,6 +71,7 @@ #+cmu (setf bt::*ignore-hidden-slots-for-pcl* t) (mapcar (lambda (path) (do () (nil) + #+lispworks-personal-edition (hcl:mark-and-sweep 3) (with-simple-restart (retry "Retry loading ~S" path) (return (handler-bind @@ -86,5 +97,14 @@ "special-operators" "special-operators-cl")))))) -#+cmu18 (setf movitz:*compiler-compile-eval-whens* nil - movitz:*compiler-compile-macro-expanders* nil) \ No newline at end of file +#+(and cmu18 (not cmu19)) +(setf movitz:*compiler-compile-eval-whens* nil + movitz:*compiler-compile-macro-expanders* nil) + +#+lispworks (load "muerte-packages") ; work around an apparent bug in defpackage. +#+lispworks-personal-edition +(progn + ;; (setf movitz:*compiler-compile-eval-whens* nil) + (setf movitz::*compiler-do-optimize-p* nil + movitz::*compiler-do-type-inference* nil) + (mark-and-sweep 3))

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp
by Frode Vatvedt Fjeld 13 Feb '04

13 Feb '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv20546/losp/x86-pc Modified Files: debugger.lisp Log Message: Minor edits to defpackage forms. Date: Fri Feb 13 17:11:38 2004 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.2 movitz/losp/x86-pc/debugger.lisp:1.3 --- movitz/losp/x86-pc/debugger.lisp:1.2 Mon Jan 19 06:23:52 2004 +++ movitz/losp/x86-pc/debugger.lisp Fri Feb 13 17:11:38 2004 @@ -10,27 +10,27 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.2 2004/01/19 11:23:52 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.3 2004/02/13 22:11:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (provide :x86-pc/debugger) (defpackage muerte.debug - (:use muerte.cl muerte muerte.x86-pc) - (:export *debugger-function* - *debugger-condition* - *backtrace-conflate-names* - *backtrace-do-conflate* - *backtrace-max-frames* - *backtrace-max-args* - *backtrace-on-error* - *backtrace-stack-frame-barrier* - *backtrace-do-fresh-lines* - *backtrace-be-spartan-p* - *backtrace-print-length* - *backtrace-print-level* - backtrace + (:use #:muerte.cl #:muerte #:muerte.x86-pc) + (:export #:*debugger-function* + #:*debugger-condition* + #:*backtrace-conflate-names* + #:*backtrace-do-conflate* + #:*backtrace-max-frames* + #:*backtrace-max-args* + #:*backtrace-on-error* + #:*backtrace-stack-frame-barrier* + #:*backtrace-do-fresh-lines* + #:*backtrace-be-spartan-p* + #:*backtrace-print-length* + #:*backtrace-print-level* + #:backtrace )) (in-package muerte.debug)

1 0