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

[movitz-cvs] CVS update: movitz/special-operators.lisp
by ffjeld＠common-lisp.net 20 Aug '05

20 Aug '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26934 Modified Files: special-operators.lisp Log Message: Re-worked several aspects of binding/environments: assignment, type-inference, etc. Date: Sat Aug 20 22:31:25 2005 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.52 movitz/special-operators.lisp:1.53 --- movitz/special-operators.lisp:1.52 Thu May 5 17:16:33 2005 +++ movitz/special-operators.lisp Sat Aug 20 22:31:25 2005 @@ -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.52 2005/05/05 15:16:33 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.53 2005/08/20 20:31:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1015,6 +1015,7 @@ ((:lexical-binding) result-mode)))) (compiler-values () :returns returns + :type 'number :code `((:add ,(movitz-binding term1 env) ,(movitz-binding term2 env) ,returns))))))) (define-special-operator muerte::include (&form form)

1 0

[movitz-cvs] CVS update: movitz/special-operators-cl.lisp
by ffjeld＠common-lisp.net 20 Aug '05

20 Aug '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26842 Modified Files: special-operators-cl.lisp Log Message: Re-worked several aspects of binding/environments: assignment, type-inference, etc. Date: Sat Aug 20 22:31:15 2005 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.46 movitz/special-operators-cl.lisp:1.47 --- movitz/special-operators-cl.lisp:1.46 Sun Feb 27 03:28:33 2005 +++ movitz/special-operators-cl.lisp Sat Aug 20 22:31:15 2005 @@ -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.46 2005/02/27 02:28:33 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.47 2005/08/20 20:31:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -61,10 +61,12 @@ (local-env (make-local-movitz-environment env funobj :type 'let-env :declarations declarations)) - (init-env (make-instance 'with-things-on-stack-env + (init-env #+ignore env + (make-instance 'movitz-environment :uplink env :funobj funobj :extent-uplink local-env)) + (stack-used 0) (binding-var-codes (loop for (var init-form) in let-vars if (movitz-env-get var 'special nil local-env) @@ -75,21 +77,21 @@ (append (if (= 0 (num-specials local-env)) ; first special? .. binding tail `((:locally (:pushl (:edi (:edi-offset dynamic-env))))) `((:pushl :esp))) - (prog1 nil (incf (stack-used init-env))) (compiler-call #'compile-form ; binding value + :with-stack-used (incf stack-used) :env init-env :defaults all :form init-form :modify-accumulate let-modifies :result-mode :push) `((:pushl :edi)) ; scratch - (prog1 nil (incf (stack-used init-env) 2)) (compiler-call #'compile-self-evaluating ; binding name + :with-stack-used (incf stack-used 2) :env init-env :defaults all :form var :result-mode :push) - (prog1 nil (incf (stack-used init-env)))) + (prog1 nil (incf stack-used))) nil t) and do (movitz-env-add-binding local-env (make-instance 'dynamic-binding :name var)) @@ -103,10 +105,11 @@ &final-form final-form) (compiler-call #'compile-form-to-register :env init-env + :extent local-env :defaults all :form init-form :modify-accumulate let-modifies) -;;; ;; (warn "prod: ~S, type: ~S" prod type) +;;; (warn "var ~S, type: ~S" var type) ;;; (warn "var ~S init: ~S.." var init-form) ;;; (print-code 'init ;;; (compiler-call #'compile-form @@ -163,6 +166,7 @@ (check-type dest-binding lexical-binding) (compiler-call #'compile-form :forward all + :extent local-env :result-mode dest-binding :form (second (first binding-var-codes))))) #+ignore @@ -178,156 +182,178 @@ (break "Yuhu: tmp ~S" tmp-binding) )) - (t (let ((code (append - (loop - for ((var init-form init-code functional-p type init-register - final-form) - . 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 - ((and (typep binding 'located-binding) - (not (binding-lended-p binding)) -;;; (= 1 (length init-code)) -;;; (eq :load-lexical (first (first init-code))) - (typep final-form 'lexical-binding) - (let ((target-binding final-form)) - (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 + (t (let ((code + (append + (loop + for ((var init-form init-code functional-p type init-register + final-form) + . 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 + ((and (typep binding 'located-binding) + (not (binding-lended-p binding)) + (typep final-form 'lexical-binding) + (let ((target-binding final-form)) + (and (typep target-binding 'lexical-binding) + (eq (binding-funobj binding) + (binding-funobj target-binding)) + #+ignore + (sub-env-p (binding-env binding) + (binding-env 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))) + (and (= 1 (length body-code)) + (eq :add (caar body-code))) + (and (>= 1 (length body-code)) + (warn "short let body: ~S" body-code)) + ;; 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)) - (notany (lambda (code) - (code-uses-binding-p (third code) - target-binding - :load t - :store t)) - rest-codes)))))) - ;; replace read-only binding with the outer binding - #+ignore (warn "replace ~S in ~S with outer ~S" - binding (binding-funobj binding) - (second (first init-code))) - (compiler-values-bind (&code new-init-code &final-form target) - (compiler-call #'compile-form-unprotected - :form init-form - :result-mode :ignore - :env init-env - :defaults all) - (check-type target lexical-binding) - (change-class binding 'forwarding-binding - :target-binding target) - (append new-init-code - `((:init-lexvar ,binding - :init-with-register ,target - :init-with-type ,target))))) - ((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))) - (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)))) - (cond - ((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)))) - ((and (typep final-form 'lexical-binding) - (eq (binding-funobj final-form) - funobj)) - (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 ,final-form - ;; :init-with-type ,final-form - )))) - ((typep final-form 'constant-object-binding) - #+ignore - (warn "type: ~S or ~S" final-form - (type-specifier-primary type)) - (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 ,final-form - :init-with-type ,(type-specifier-primary type) - )))) - (t ;; (warn "for ~S ~S ~S" binding init-register final-form) - (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 (:call (:edi ,(bt:slot-offset 'movitz-run-time-context - 'dynamic-variable-install)))) - (:locally (:movl :esp (:edi (:edi-offset dynamic-env)))))) - body-code - (when (and (plusp (num-specials local-env)) - (not (eq :non-local-exit body-returns))) - #+ignore - (warn "let spec ret: ~S, want: ~S ~S" - body-returns result-mode let-var-specs) - `((:movl (:esp ,(+ -4 (* 16 (num-specials local-env)))) :edx) - (:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context - 'dynamic-variable-uninstall)))) - (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) - (:leal (:esp ,(* 16 (num-specials local-env))) :esp)))))) + rest-codes)))))) + ;; replace read-only binding with the outer binding + (compiler-values-bind (&code new-init-code &final-form target + &type type) + (compiler-call #'compile-form-unprotected + :extent local-env + :form init-form + :result-mode :ignore + :env init-env + :defaults all) + (check-type target lexical-binding) + (change-class binding 'forwarding-binding + :target-binding target) + (let ((btype (if (multiple-value-call #'encoded-allp + (type-specifier-encode + (type-specifier-primary type))) + target + (type-specifier-primary type)))) + #+ignore (warn "forwarding ~S -[~S]> ~S" + binding btype target) + (append new-init-code + `((:init-lexvar + ,binding + :init-with-register ,target + :init-with-type ,btype)))))) + ((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))) + (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 + :extent local-env + :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)))) + (cond + ((and init (eq *movitz-nil* (car init))) + (append (if functional-p + nil + (compiler-call #'compile-form-unprotected + :extent local-env + :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)))) + ((and (typep final-form 'lexical-binding) + (eq (binding-funobj final-form) + funobj)) + (compiler-values-bind (&code new-init-code + &type new-type + &final-form new-binding) + (compiler-call #'compile-form-unprotected + :extent local-env + :env init-env + :defaults all + :form init-form + :result-mode :ignore + :modify-accumulate let-modifies) + (append (if functional-p + nil + new-init-code) + (let ((ptype (type-specifier-primary new-type))) + `((:init-lexvar ,binding + :init-with-register ,new-binding + :init-with-type ,ptype + )))))) + ((typep final-form 'constant-object-binding) + #+ignore + (warn "type: ~S or ~S" final-form + (type-specifier-primary type)) + (append (if functional-p + nil + (compiler-call #'compile-form-unprotected + :extent local-env + :env init-env + :defaults all + :form init-form + :result-mode :ignore + :modify-accumulate let-modifies)) + `((:init-lexvar + ,binding + :init-with-register ,final-form + :init-with-type ,(type-specifier-primary type) + )))) + (t ;; (warn "for ~S ~S ~S" binding init-register final-form) + (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 (:call (:edi ,(bt:slot-offset 'movitz-run-time-context + 'dynamic-variable-install)))) + (:locally (:movl :esp (:edi (:edi-offset dynamic-env)))))) + body-code + (when (and (plusp (num-specials local-env)) + (not (eq :non-local-exit body-returns))) + #+ignore + (warn "let spec ret: ~S, want: ~S ~S" + body-returns result-mode let-var-specs) + `((:movl (:esp ,(+ -4 (* 16 (num-specials local-env)))) :edx) + (:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context + 'dynamic-variable-uninstall)))) + (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) + (:leal (:esp ,(* 16 (num-specials local-env))) :esp)))))) (compiler-values (body-values) :returns body-returns :producer (default-compiler-values-producer)

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by ffjeld＠common-lisp.net 20 Aug '05

20 Aug '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26759 Modified Files: image.lisp Log Message: Re-worked several aspects of binding/environments: assignment, type-inference, etc. Date: Sat Aug 20 22:31:05 2005 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.101 movitz/image.lisp:1.102 --- movitz/image.lisp:1.101 Sun May 22 00:38:39 2005 +++ movitz/image.lisp Sat Aug 20 22:31:05 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.101 2005/05/21 22:38:39 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.102 2005/08/20 20:31:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -957,60 +957,61 @@ (format t "~&;; Image file size: ~D octets.~%" image-end) ;; Write simple stage1 bootblock into sector 0.. (format t "~&;; Dump count: ~D." (incf (dump-count *image*))) - (set-file-position stream 0) (flet ((global-slot-position (slot-name) (+ 512 (image-nil-word *image*) (image-ds-segment-base *image*) (global-constant-offset slot-name) (- load-address)))) - (let ((bootblock (make-bootblock kernel-size - load-address - init-code-address))) - (setf (image-bootblock *image*) bootblock) - (write-sequence bootblock stream) - (let* ((stack-vector-address (+ (image-nil-word *image*) - (global-constant-offset 'stack-vector) - (image-ds-segment-base *image*))) - (stack-vector-position (- (+ stack-vector-address 512) - load-address))) - (declare (ignore stack-vector-position)) - #+ignore(warn "stack-v-pos: ~S => ~S" - stack-vector-position - stack-vector-word) - (set-file-position stream (global-slot-position 'stack-vector) 'stack-vector) - (write-binary 'word stream stack-vector-word) - (set-file-position stream (global-slot-position 'stack-bottom) 'stack-bottom) - (write-binary 'lu32 stream (+ 8 (* 4 4096) ; cushion - (- stack-vector-word (tag :other)))) - (set-file-position stream (global-slot-position 'stack-top) 'stack-top) - (write-binary 'lu32 stream (+ 8 (- stack-vector-word (tag :other)) - (* 4 (movitz-vector-num-elements stack-vector))))) - (if (not multiboot-p) - (format t "~&;; No multiboot header.") - ;; Update multiboot header, symbolic and in the file.. - (let* ((mb (image-multiboot-header *image*)) - (mb-address (+ (movitz-intern mb) - (slot-offset 'multiboot-header 'magic) - (image-ds-segment-base *image*))) - (mb-file-position (- (+ mb-address 512) - load-address - (slot-offset 'multiboot-header 'magic)))) - (when (< load-address #x100000) - (warn "Multiboot load-address #x~x is below the 1MB mark." - load-address)) - (when (> (+ mb-file-position (sizeof mb)) 8192) - (warn "Multiboot header at position ~D is above the 8KB mark, ~ + (with-simple-restart (continue "Don't write a floppy bootloader.") + (let ((bootblock (make-bootblock kernel-size + load-address + init-code-address))) + (setf (image-bootblock *image*) bootblock) + (set-file-position stream 0) + (write-sequence bootblock stream))) + (let* ((stack-vector-address (+ (image-nil-word *image*) + (global-constant-offset 'stack-vector) + (image-ds-segment-base *image*))) + (stack-vector-position (- (+ stack-vector-address 512) + load-address))) + (declare (ignore stack-vector-position)) + #+ignore(warn "stack-v-pos: ~S => ~S" + stack-vector-position + stack-vector-word) + (set-file-position stream (global-slot-position 'stack-vector) 'stack-vector) + (write-binary 'word stream stack-vector-word) + (set-file-position stream (global-slot-position 'stack-bottom) 'stack-bottom) + (write-binary 'lu32 stream (+ 8 (* 4 4096) ; cushion + (- stack-vector-word (tag :other)))) + (set-file-position stream (global-slot-position 'stack-top) 'stack-top) + (write-binary 'lu32 stream (+ 8 (- stack-vector-word (tag :other)) + (* 4 (movitz-vector-num-elements stack-vector))))) + (if (not multiboot-p) + (format t "~&;; No multiboot header.") + ;; Update multiboot header, symbolic and in the file.. + (let* ((mb (image-multiboot-header *image*)) + (mb-address (+ (movitz-intern mb) + (slot-offset 'multiboot-header 'magic) + (image-ds-segment-base *image*))) + (mb-file-position (- (+ mb-address 512) + load-address + (slot-offset 'multiboot-header 'magic)))) + (when (< load-address #x100000) + (warn "Multiboot load-address #x~x is below the 1MB mark." + load-address)) + (when (> (+ mb-file-position (sizeof mb)) 8192) + (warn "Multiboot header at position ~D is above the 8KB mark, ~ this image will not be Multiboot compatible." - (+ mb-file-position (sizeof mb)))) - (set-file-position stream mb-file-position 'multiboot-header) - ;; (format t "~&;; Multiboot load-address: #x~X." load-address) - (setf (header-address mb) mb-address - (load-address mb) load-address - (load-end-address mb) (+ load-address kernel-size) - (bss-end-address mb) (+ load-address kernel-size) - (entry-address mb) init-code-address) - (write-binary-record mb stream))))))))))) + (+ mb-file-position (sizeof mb)))) + (set-file-position stream mb-file-position 'multiboot-header) + ;; (format t "~&;; Multiboot load-address: #x~X." load-address) + (setf (header-address mb) mb-address + (load-address mb) load-address + (load-end-address mb) (+ load-address kernel-size) + (bss-end-address mb) (+ load-address kernel-size) + (entry-address mb) init-code-address) + (write-binary-record mb stream)))))))))) (values)) (defun dump-image-core (image stream)

1 0

[movitz-cvs] CVS update: movitz/environment.lisp
by ffjeld＠common-lisp.net 20 Aug '05

20 Aug '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26719 Modified Files: environment.lisp Log Message: Re-worked several aspects of binding/environments: assignment, type-inference, etc. Date: Sat Aug 20 22:30:57 2005 Author: ffjeld Index: movitz/environment.lisp diff -u movitz/environment.lisp:1.13 movitz/environment.lisp:1.14 --- movitz/environment.lisp:1.13 Sun Aug 14 14:13:07 2005 +++ movitz/environment.lisp Sat Aug 20 22:30:54 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 3 11:40:15 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: environment.lisp,v 1.13 2005/08/14 12:13:07 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.14 2005/08/20 20:30:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -225,7 +225,7 @@ (find-function-env (movitz-environment-uplink env) funobj))) (defun sub-env-p (sub-env env) - "Check if sub-env is a sub-environment of env." + "Check if sub-env is a sub-environment (or eq) of env." (cond ((not sub-env) nil)

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by ffjeld＠common-lisp.net 20 Aug '05

20 Aug '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26448 Modified Files: compiler.lisp Log Message: Re-worked several aspects of binding/environments: assignment, type-inference, etc. Date: Sat Aug 20 22:30:44 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.149 movitz/compiler.lisp:1.150 --- movitz/compiler.lisp:1.149 Mon Aug 15 23:44:23 2005 +++ movitz/compiler.lisp Sat Aug 20 22:30:40 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.149 2005/08/15 21:44:23 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.150 2005/08/20 20:30:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -473,7 +473,7 @@ (assert (or (typep type 'binding) (eql 1 (type-specifier-num-values type))) () "store-lexical with multiple-valued type: ~S for ~S" type binding) - ;; (warn "store ~S type ~S, thunk ~S" binding type thunk) + #+ignore (warn "store ~S type ~S, thunk ~S" binding type thunk) (let ((analysis (or (gethash binding binding-usage) (setf (gethash binding binding-usage) (make-type-analysis-with-declaration binding))))) @@ -492,14 +492,14 @@ (values-list (type-analysis-encoded-type analysis)) (type-specifier-encode type)))))))) (analyze-code (code) + #+ignore (print-code 'analyze code) (dolist (instruction code) (when (listp instruction) (multiple-value-bind (store-binding store-type thunk thunk-args) (find-written-binding-and-type instruction) (when store-binding - #+ignore - (warn "store: ~S binding ~S type ~S thunk ~S" - instruction store-binding store-type thunk) + #+ignore (warn "store: ~S binding ~S type ~S thunk ~S" + instruction store-binding store-type thunk) (analyze-store store-binding store-type thunk thunk-args))) (analyze-code (instruction-sub-program instruction))))) (analyze-funobj (funobj) @@ -617,6 +617,8 @@ ;; Binding is local to this funobj (typecase binding (forwarding-binding + (process-binding funobj (forwarding-binding-target binding) usages) + #+ignore (setf (forwarding-binding-target binding) (process-binding funobj (forwarding-binding-target binding) usages))) (function-binding @@ -2377,7 +2379,14 @@ :accessor binding-env) (declarations :initarg :declarations - :accessor binding-declarations))) + :accessor binding-declarations) + (extent-env + :accessor binding-extent-env + :initform nil))) + +(defmethod (setf binding-env) :after (env (binding binding)) + (unless (binding-extent-env binding) + (setf (binding-extent-env binding) env))) (defmethod print-object ((object binding) stream) (print-unreadable-object (object stream :type t :identity t) @@ -2387,12 +2396,13 @@ (binding-name object)) (when (and (binding-target object) (not (eq object (binding-target object)))) - (binding-name (binding-target object))) + (binding-name (forwarding-binding-target object))) (when (and #+ignore (slot-exists-p object 'store-type) #+ignore (slot-boundp object 'store-type) (binding-store-type object)) - (apply #'encoded-type-decode - (binding-store-type object))))))) + (or (apply #'encoded-type-decode + (binding-store-type object)) + 'empty)))))) (defclass constant-object-binding (binding) ((object @@ -2653,11 +2663,11 @@ '((:int 100)) :test #'equalp))) -(defun sub-environment-p (env1 env2) - (cond - ((eq env1 env2) t) - ((null env1) nil) - (t (sub-environment-p (movitz-environment-uplink env1) env2)))) +#+ignore (defun sub-environment-p (env1 env2) + (cond + ((eq env1 env2) t) + ((null env1) nil) + (t (sub-environment-p (movitz-environment-uplink env1) env2)))) (defun find-code-constants-and-jumpers (code &key include-programs) "Return code's constants (a plist of constants and their usage-counts) and jumper-sets." @@ -3006,7 +3016,7 @@ sub-environments found in CODE. A frame-map which is an assoc from bindings to stack-frame locations." ;; Then assign them to locations in the stack-frame. - ;; (warn "assigning code:~%~{~& ~A~}" code) + #+ignore (warn "assigning code:~%~{~& ~A~}" code) (check-type function-env function-env) (assert (= initial-stack-frame-position (1+ (frame-map-size frame-map)))) @@ -3022,10 +3032,42 @@ (error "SEFEW: ~S" function-env)) ;; The floor of this env is the roof of its extent-uplink. (t (assign-env-bindings (movitz-environment-extent-uplink env))))) + ;; PROMOTE FORW-BINDINGS TO UPPER ENV!! (assign-env-bindings (env) (or (getf env-roof-map env nil) (let* ((stack-frame-position (env-floor env)) (bindings-to-locate + (loop for binding being the hash-keys of var-counts + when (eq env (binding-extent-env binding)) + unless (let ((variable (binding-name binding))) + (cond + ((not (typep binding 'lexical-binding))) + ((typep binding 'lambda-binding)) + ((typep binding 'constant-object-binding)) + ((typep binding 'forwarding-binding) + ;; Immediately "assign" to target. + (when (plusp (or (car (gethash binding var-counts)) 0)) + (setf (new-binding-location binding frame-map) + (forwarding-binding-target binding))) + t) + ((typep binding 'borrowed-binding)) + ((typep binding 'funobj-binding)) + ((and (typep binding 'fixed-required-function-argument) + (plusp (or (car (gethash binding var-counts)) 0))) + (prog1 nil ; may need lending-cons + (setf (new-binding-location binding frame-map) + `(:argument-stack ,(function-argument-argnum binding))))) + ((unless (or (movitz-env-get variable 'ignore nil + (binding-env binding) nil) + (movitz-env-get variable 'ignorable nil + (binding-env binding) nil) + (typep binding 'hidden-rest-function-argument) + (third (gethash binding var-counts))) + (warn "Unused variable: ~S" + (binding-name binding)))) + ((not (plusp (or (car (gethash binding var-counts)) 0)))))) + collect binding) + #+ignore (loop for (variable . binding) in (movitz-environment-bindings env) unless (cond ((not (typep binding 'lexical-binding))) @@ -3087,6 +3129,22 @@ (cdr init-pc)) 15) count))))))))) + #+ignore (labels ((dox (env upper) + (if (or (not env) + (not (sub-env-p env function-env))) + 0 + (let ((level (dox (funcall upper env) upper))) + (format t "~%~v{ ~}~S" level t env) + (+ level 4))))) + (warn "At ~S binding ~S:~{ ~S~}: Extent: ~A~%Bind: ~A" + stack-frame-position + env bindings-to-locate + (with-output-to-string (*standard-output*) + (dox env #'movitz-environment-extent-uplink)) + (with-output-to-string (*standard-output*) + (when bindings-to-locate + (dox (binding-env (first bindings-to-locate)) + #'movitz-environment-uplink))))) ;; First, make several passes while trying to locate bindings ;; into registers. (loop repeat 100 with try-again = t and did-assign = t @@ -3181,6 +3239,8 @@ (setf (new-binding-location binding frame-map) `(:argument-stack ,(function-argument-argnum binding)))) (located-binding + #+ignore (warn "Assigning ~S at ~S" + binding stack-frame-position) (setf (new-binding-location binding frame-map) (post-incf stack-frame-position)))))) (setf (getf env-roof-map env) @@ -3190,7 +3250,7 @@ ;; do (warn "bind: ~S: ~S" binding (eq function-env (find-function-env env funobj))) when (sub-env-p env function-env) do (assign-env-bindings (binding-env binding))) - ;; (warn "Frame-map:~{ ~A~}" frame-map) + #+ignore (warn "Frame-map:~{ ~A~}" frame-map) frame-map))) @@ -3269,7 +3329,7 @@ "Resolve a binding in terms of forwarding." (etypecase binding (forwarding-binding - (forwarding-binding-target binding)) + (binding-target (forwarding-binding-target binding))) (binding binding))) @@ -3460,8 +3520,8 @@ ;;; :untagged-fixnum-ecx)) ((and binding-type (type-specifier-singleton decoded-type)) - (warn "Immloadlex: ~S" - (type-specifier-singleton decoded-type)) + #+ignore (warn "Immloadlex: ~S" + (type-specifier-singleton decoded-type)) (make-immediate-move (movitz-immediate-value (car (type-specifier-singleton decoded-type))) :ecx)) @@ -3571,6 +3631,7 @@ (located-binding (let ((binding-type (binding-store-type binding)) (binding-location (new-binding-location binding frame-map))) + #+ignore (warn "~S type: ~S" binding binding-type) (cond ((and (binding-lended-p binding) (not shared-reference-p)) @@ -5349,13 +5410,32 @@ :result-mode :eax :forward form-info))))) -(define-compiler compile-form-unprotected (&all all &form form &result-mode result-mode) +(define-compiler compile-form-unprotected (&all downstream &form form &result-mode result-mode + &extent extent) "3.1.2.1 Form Evaluation. May not honor RESULT-MODE. That is, RESULT-MODE is taken to be a suggestion, not an imperative." - (typecase form - (symbol (compiler-call #'compile-symbol :forward all)) - (cons (compiler-call #'compile-cons :forward all)) - (t (compiler-call #'compile-self-evaluating :forward all)))) + (compiler-values-bind (&all upstream) + (typecase form + (symbol (compiler-call #'compile-symbol :forward downstream)) + (cons (compiler-call #'compile-cons :forward downstream)) + (t (compiler-call #'compile-self-evaluating :forward downstream))) + (when (typep (upstream :final-form) 'lexical-binding) + (labels ((fix-extent (binding) + (cond + ((sub-env-p extent (binding-extent-env binding)) + #+ignore (warn "Binding ~S OK in ~S wrt. ~S." + binding + (binding-extent-env binding) + (downstream :env))) + (t #+ignore (break "Binding ~S escapes from ~S to ~S" + binding (binding-extent-env binding) + extent) + (setf (binding-extent-env binding) extent))) + (when (typep binding 'forwarding-binding) + (fix-extent (forwarding-binding-target binding))))) + (when extent + (fix-extent (upstream :final-form))))) + (compiler-values (upstream)))) (defun lambda-form-p (form) (and (listp form) @@ -6092,17 +6172,20 @@ (:jne ',push-values-loop) ,push-values-done))) +(defun stack-add (x y) + (if (and (integerp x) (integerp y)) + (+ x y) + t)) + +(define-modify-macro stack-incf (&optional (delta 1)) stack-add) + (defun stack-delta (inner-env outer-env) "Calculate the amount of stack-space used (in 32-bit stack slots) at the time of <inner-env> since <outer-env>, the number of intervening dynamic-slots (special bindings, unwind-protects, and catch-tags), and a list of any intervening unwind-protect environment-slots." (labels - ((stack-distance-add (x y) - (if (and (integerp x) (integerp y)) - (+ x y) - t)) - (find-stack-delta (env stack-distance num-dynamic-slots unwind-protects) + ((find-stack-delta (env stack-distance num-dynamic-slots unwind-protects) #+ignore (warn "find-stack-delta: ~S dist ~S, slots ~S" env (stack-used env) (num-dynamic-slots env)) (cond @@ -6116,8 +6199,8 @@ ((null env) (values nil 0 nil)) (t (find-stack-delta (movitz-environment-uplink env) - (stack-distance-add stack-distance (stack-used env)) - (stack-distance-add num-dynamic-slots (num-dynamic-slots env)) + (stack-add stack-distance (stack-used env)) + (stack-add num-dynamic-slots (num-dynamic-slots env)) (if (typep env 'unwind-protect-env) (cons env unwind-protects) unwind-protects)))))) @@ -6334,6 +6417,8 @@ ((not (typep init-with-register 'binding)) (assert init-with-type) (values binding init-with-type) ) + ((and init-with-type (not (bindingp init-with-type))) + (values binding init-with-type)) (t (values binding t (lambda (x) x) (list init-with-register))))) @@ -6701,12 +6786,18 @@ (warn "Add for lend0: ~S" destination)) (let ((loc0 (new-binding-location (binding-target term0) frame-map :default nil)) (loc1 (new-binding-location (binding-target term1) frame-map :default nil))) -;;; (warn "add: ~A" instruction) + #+ignore + (warn "add: ~A for ~A" instruction result-type) #+ignore (warn "add for: ~S is ~A, from ~A/~A and ~A/~A." destination result-type term0 loc0 term1 loc1) + #+ignore + (when (eql loc0 loc1) + (warn "add for:~%~A/~A in ~S~&~A/~A in ~S." + term0 loc0 (binding-extent-env (binding-target term0)) + term1 loc1 (binding-extent-env (binding-target term1)))) (cond ((type-specifier-singleton result-type) ;; (break "constant add: ~S" instruction) @@ -6744,7 +6835,7 @@ ((and (movitz-subtypep type0 'fixnum) (movitz-subtypep type1 'fixnum) (movitz-subtypep result-type 'fixnum)) - ;; (warn "ADDX: ~S" instruction) + #+ignore (warn "ADDX: ~S" instruction) (cond ((and (type-specifier-singleton type0) (eq loc1 destination-location)) @@ -6752,10 +6843,14 @@ ((member destination-location '(:eax :ebx :ecx :edx)) `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) ,destination))) - (t (assert (integerp loc1)) - (break "check that this is correct..") - `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) - (:ebp ,(stack-frame-offset loc1))))))) + ((integerp loc1) + ;; (break "check that this is correct..") + `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) + (:ebp ,(stack-frame-offset loc1))))) + ((eq :argument-stack (operator loc1)) + `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) + (:ebp ,(argument-stack-offset (binding-target term1)))))) + (t (error "Don't know how to add this for loc1 ~S" loc1)))) ((and (type-specifier-singleton type0) (eq term1 destination) (integerp destination-location)) @@ -6768,41 +6863,44 @@ (append `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) ,loc1)) (make-store-lexical destination loc1 nil funobj frame-map))) - (t #+ignore (warn "ADD: ~A/~S = ~A/~S + ~A/~S,~%~A ~A" - destination-location - destination - loc0 term0 - loc1 term1 - (type-specifier-singleton type0) - (eq loc1 destination)) + ((and (integerp loc0) (integerp loc1) + (member destination-location '(:eax :ebx :ecx :edx))) + (append `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location) + (:addl (:ebp ,(stack-frame-offset loc1)) ,destination-location)))) + (t (warn "ADD: ~A/~S = ~A/~S + ~A/~S" + destination-location + destination + loc0 term0 + loc1 term1) + #+ignore (warn "map: ~A" frame-map) ;;; (warn "ADDI: ~S" instruction) - (append (cond - ((type-specifier-singleton type0) - (append (make-load-lexical term1 :eax funobj nil frame-map) - (make-load-constant (car (type-specifier-singleton type0)) - :ebx funobj frame-map))) - ((type-specifier-singleton type1) - (append (make-load-lexical term0 :eax funobj nil frame-map) - (make-load-constant (car (type-specifier-singleton type1)) - :ebx funobj frame-map))) - ((and (eq :eax loc0) (eq :ebx loc1)) - nil) - ((and (eq :ebx loc0) (eq :eax loc1)) - nil) ; terms order isn't important - ((eq :eax loc1) - (append - (make-load-lexical term0 :ebx funobj nil frame-map))) - (t (append - (make-load-lexical term0 :eax funobj nil frame-map) - (make-load-lexical term1 :ebx funobj nil frame-map)))) - `((:movl (:edi ,(global-constant-offset '+)) :esi)) - (make-compiled-funcall-by-esi 2) - (etypecase destination - (symbol - (unless (eq destination :eax) - `((:movl :eax ,destination)))) - (binding - (make-store-lexical destination :eax nil funobj frame-map))))))) + (append (cond + ((type-specifier-singleton type0) + (append (make-load-lexical term1 :eax funobj nil frame-map) + (make-load-constant (car (type-specifier-singleton type0)) + :ebx funobj frame-map))) + ((type-specifier-singleton type1) + (append (make-load-lexical term0 :eax funobj nil frame-map) + (make-load-constant (car (type-specifier-singleton type1)) + :ebx funobj frame-map))) + ((and (eq :eax loc0) (eq :ebx loc1)) + nil) + ((and (eq :ebx loc0) (eq :eax loc1)) + nil) ; terms order isn't important + ((eq :eax loc1) + (append + (make-load-lexical term0 :ebx funobj nil frame-map))) + (t (append + (make-load-lexical term0 :eax funobj nil frame-map) + (make-load-lexical term1 :ebx funobj nil frame-map)))) + `((:movl (:edi ,(global-constant-offset '+)) :esi)) + (make-compiled-funcall-by-esi 2) + (etypecase destination + (symbol + (unless (eq destination :eax) + `((:movl :eax ,destination)))) + (binding + (make-store-lexical destination :eax nil funobj frame-map))))))) (t (append (cond ((type-specifier-singleton type0) (append (make-load-lexical term1 :eax funobj nil frame-map) @@ -6848,12 +6946,13 @@ (rotatef x y) (rotatef x-type y-type) (rotatef x-singleton y-singleton)) - (let (;; (x-loc (new-binding-location (binding-target x) frame-map :default nil)) + (let (#+ignore (x-loc (new-binding-location (binding-target x) frame-map :default nil)) (y-loc (new-binding-location (binding-target y) frame-map :default nil))) #+ignore - (warn "eql ~S/~S ~S/~S" - x x-loc - y y-loc) + (warn "eql ~S/~S xx~Xxx ~S/~S: ~S" + x x-loc (binding-target y) + y y-loc + instruction) (flet ((make-branch () (ecase (operator return-mode) (:boolean-branch-on-false

1 0

[movitz-cvs] CVS update: movitz/compiler-types.lisp
by ffjeld＠common-lisp.net 20 Aug '05

20 Aug '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26351 Modified Files: compiler-types.lisp Log Message: Re-worked several aspects of binding/environments: assignment, type-inference, etc. Date: Sat Aug 20 22:30:14 2005 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.22 movitz/compiler-types.lisp:1.23 --- movitz/compiler-types.lisp:1.22 Mon Jan 3 12:52:33 2005 +++ movitz/compiler-types.lisp Sat Aug 20 22:30:14 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001, 2003-2004, +;;;; Copyright (C) 2001, 2003-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -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.22 2005/01/03 11:52:33 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.23 2005/08/20 20:30:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -153,7 +153,7 @@ (<= max (+ (car sub-range) epsilon)))) (d (and min (cdr sub-range) ; subtrahend starts above sub-range? (<= (+ (cdr sub-range) epsilon) min)))) - ;; (warn "abcd: ~S ~S ~S ~S" a b c d) + #+ignore (warn "abcd: ~S ~S ~S ~S" a b c d) (cond ((and a b) ;; sub-range is eclipsed by the subtrahend. @@ -173,8 +173,8 @@ (numscope-add-range new-numscope (+ max epsilon) (cdr sub-range) epsilon))) ((and (not d) b) ; (warn "right prune ~D with [~D-~D]" sub-range min max) (setf new-numscope - (numscope-add-range new-numscope (car sub-range) min epsilon))) - (t (error "I am confused!"))))) + (numscope-add-range new-numscope (car sub-range) (- min epsilon) epsilon))) + (t (break "I am confused!"))))) new-numscope)))) (defun numscope-complement (numscope &optional (epsilon 1)) @@ -277,34 +277,35 @@ :initial-value (code first-type))))) (defun encoded-type-decode (code integer-range members include complement) - (if (let ((mask (1- (ash 1 (position :tail *tb-bitmap*))))) - (= mask (logand mask code))) - (not complement) - (let ((sub-specs include)) - (loop for x in *tb-bitmap* as bit upfrom 0 - do (when (logbitp bit code) - (push x sub-specs))) - (when (not (null members)) - (push (cons 'member members) sub-specs)) - (when (numscope-allp integer-range) - (pushnew 'integer sub-specs)) - (when (and (not (member 'integer sub-specs)) - integer-range) - (dolist (sub-range integer-range) - (push (list 'integer - (or (car sub-range) '*) - (or (cdr sub-range) '*)) - sub-specs))) - (cond - ((null sub-specs) - (if complement t nil)) - ((not (cdr sub-specs)) - (if (not complement) - (car sub-specs) - (list 'not (car sub-specs)))) - (t (if (not complement) - (cons 'or sub-specs) - (list 'not (cons 'or sub-specs)))))))) + (cond + ((let ((mask (1- (ash 1 (position :tail *tb-bitmap*))))) + (= mask (logand mask code))) + (not complement)) + (t (let ((sub-specs include)) + (loop for x in *tb-bitmap* as bit upfrom 0 + do (when (logbitp bit code) + (push x sub-specs))) + (when (not (null members)) + (push (cons 'member members) sub-specs)) + (when (numscope-allp integer-range) + (pushnew 'integer sub-specs)) + (when (and (not (member 'integer sub-specs)) + integer-range) + (dolist (sub-range integer-range) + (push (list 'integer + (or (car sub-range) '*) + (or (cdr sub-range) '*)) + sub-specs))) + (cond + ((null sub-specs) + (if complement t nil)) + ((not (cdr sub-specs)) + (if (not complement) + (car sub-specs) + (list 'not (car sub-specs)))) + (t (if (not complement) + (cons 'or sub-specs) + (list 'not (cons 'or sub-specs))))))))) (defun type-values (codes &key integer-range members include complement) ;; Members: A list of objects explicitly included in type. @@ -312,6 +313,8 @@ (check-type include list) (check-type members list) (check-type integer-range list) + (when (eq 'and (car include)) + (break "foo")) (let ((new-intscope integer-range) (new-members ())) (dolist (member members) ; move integer members into integer-range @@ -392,6 +395,19 @@ (not (encoded-typep t nil x code0 integer-range0 members0 include0 nil))) members1) nil nil)) + ((and (or integer-range0 integer-range1) + (encoded-emptyp code0 nil members0 nil complement0) + (encoded-emptyp code1 nil members1 nil complement1) + (flet ((integer-super-p (x) + (member x '(rational real number t)))) + (and (every #'integer-super-p include0) + (every #'integer-super-p include1)))) + (type-values () :integer-range (numscope-intersection integer-range0 + integer-range1))) + ((and (= code0 code1) (equal integer-range0 integer-range1) + (equal members0 members1) (equal include0 include1) + (eq complement0 complement1)) + (values code0 integer-range0 members0 include0 complement0)) ((and include0 (null include1)) ;; (and (or a b c) d) => (or (and a d) (and b d) (and c d)) (values (logand code0 code1) @@ -413,19 +429,19 @@ include1) nil)) (t ;; (warn "and with two includes: ~S ~S" include0 include1) - (type-values () :include `(and ,(encoded-type-decode code0 integer-range0 members0 - include0 complement0) - ,(encoded-type-decode code1 integer-range1 members1 - include1 complement1)))))) + (type-values () :include `((and ,(encoded-type-decode code0 integer-range0 members0 + include0 complement0) + ,(encoded-type-decode code1 integer-range1 members1 + include1 complement1))))))) ((and complement0 complement1) (multiple-value-bind (code integer-range members include complement) (encoded-types-or code0 integer-range0 members0 include0 (not complement0) code1 integer-range1 members1 include1 (not complement1)) (values code integer-range members include (not complement)))) - (t (type-values () :include `(and ,(encoded-type-decode code0 integer-range0 members0 - include0 complement0) - ,(encoded-type-decode code1 integer-range1 members1 - include1 complement1)))))) + (t (type-values () :include `((and ,(encoded-type-decode code0 integer-range0 members0 + include0 complement0) + ,(encoded-type-decode code1 integer-range1 members1 + include1 complement1))))))) (defun encoded-types-or (code0 integer-range0 members0 include0 complement0 code1 integer-range1 members1 include1 complement1) @@ -659,7 +675,8 @@ (cond ((or complement include (not (= 0 code))) nil) - ((= 1 (length members)) + ((and (= 1 (length members)) + (= 0 code) (null intscope) (null include) (not complement)) members) ((and (= 1 (length intscope)) (caar intscope) @@ -680,7 +697,7 @@ "Return the integer type that can result from adding a member of type0 to a member of type1." ;; (declare (ignore members0 members1)) (cond - ((or include0 include1 members0 members1) + ((or include0 include1 members0 members1 (/= 0 code0) (/= 0 code1)) ;; We can't know.. 'number) ((or complement0 complement1)

1 0

[movitz-cvs] CVS update: movitz/compiler-protocol.lisp
by ffjeld＠common-lisp.net 20 Aug '05

20 Aug '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26187 Modified Files: compiler-protocol.lisp Log Message: Re-worked several aspects of binding/environments: assignment, type-inference, etc. Date: Sat Aug 20 22:30:04 2005 Author: ffjeld Index: movitz/compiler-protocol.lisp diff -u movitz/compiler-protocol.lisp:1.3 movitz/compiler-protocol.lisp:1.4 --- movitz/compiler-protocol.lisp:1.3 Thu Feb 12 18:51:02 2004 +++ movitz/compiler-protocol.lisp Sat Aug 20 22:30:03 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Oct 10 13:02:03 2001 ;;;; -;;;; $Id: compiler-protocol.lisp,v 1.3 2004/02/12 17:51:02 ffjeld Exp $ +;;;; $Id: compiler-protocol.lisp,v 1.4 2005/08/20 20:30:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -159,26 +159,29 @@ ((&funobj funobj-var) (copy-symbol 'funobj) funobj-p) ((&env env-var) (copy-symbol 'env) env-p) ((&top-level-p top-level-p-var) (copy-symbol 'top-level-p) top-level-p-p) - ((&result-mode result-mode-var) (copy-symbol 'result-mode) result-mode-p)) + ((&result-mode result-mode-var) (copy-symbol 'result-mode) result-mode-p) + ((&extent extent-var) (copy-symbol 'extent) extent-p)) &body defun-body) (multiple-value-bind (body docstring) (if (and (cdr defun-body) (stringp (car defun-body))) (values (cdr defun-body) (list (car defun-body))) (values defun-body nil)) - `(defun ,name (,form-var ,funobj-var ,env-var ,top-level-p-var ,result-mode-var) + `(defun ,name (,form-var ,funobj-var ,env-var ,top-level-p-var ,result-mode-var ,extent-var) ,@docstring (declare (,(if all-p 'ignorable 'ignore) ,@(unless form-p (list form-var)) ,@(unless funobj-p (list funobj-var)) ,@(unless env-p (list env-var)) ,@(unless top-level-p-p (list top-level-p-var)) - ,@(unless result-mode-p (list result-mode-var)))) + ,@(unless result-mode-p (list result-mode-var)) + ,@(unless extent-p (list extent-var)))) (macrolet ((default-compiler-values-producer () '',name) ,@(when all-p `((,all-var (v) (ecase v (:form ',form-var) (:funobj ',funobj-var) (:env ',env-var) (:top-level-p ',top-level-p-var) - (:result-mode ',result-mode-var)))))) + (:result-mode ',result-mode-var) + (:extent ',extent-var)))))) ,@body)))) (defmacro compiler-call (compiler-name &rest all-keys @@ -186,6 +189,7 @@ ((:form form-var) nil form-p) ((:funobj funobj-var) nil funobj-p) ((:env env-var) nil env-p) + ((:extent extent-var) nil extent-p) ((:top-level-p top-level-p-var) nil top-level-p-p) ((:result-mode result-mode-var) :ignore result-mode-p)) (assert (not (and defaults forward)) () @@ -208,7 +212,8 @@ ,(if funobj-p funobj-var `(,defaults :funobj)) inner-env ,(when top-level-p-p top-level-p-var) ; default to nil, no forwarding. - ,(if result-mode-p result-mode-var `(,defaults :result-mode))))) + ,(if result-mode-p result-mode-var `(,defaults :result-mode)) + ,(if extent-p extent-var `(,defaults :extent))))) (forward `(let* ((outer-env ,(if env-p env-var `(,forward :env))) (inner-env ,(if (not with-stack-used) @@ -222,15 +227,17 @@ ,(if funobj-p funobj-var `(,forward :funobj)) inner-env ,(if top-level-p-p top-level-p-var `(,forward :top-level-p)) - ,(if result-mode-p result-mode-var `(,forward :result-mode))))) + ,(if result-mode-p result-mode-var `(,forward :result-mode)) + ,(if extent-p extent-var `(,forward :extent))))) ((not with-stack-used) - `(funcall ,compiler-name ,form-var ,funobj-var ,env-var ,top-level-p-var ,result-mode-var)) + `(funcall ,compiler-name ,form-var ,funobj-var ,env-var + ,top-level-p-var ,result-mode-var ,extent-var)) (t (assert env-p () ":env is required when with-stack-used is given.") `(funcall ,compiler-name ,form-var ,funobj-var (make-instance 'with-things-on-stack-env :uplink ,env-var :stack-used ,with-stack-used :funobj (movitz-environment-funobj ,env-var)) - ,top-level-p-var ,result-mode-var)))) + ,top-level-p-var ,result-mode-var ,extent-var)))) (defmacro define-special-operator (name formals &body body) (let* ((movitz-name (intern (symbol-name (translate-program name :cl :muerte.cl))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp
by ffjeld＠common-lisp.net 20 Aug '05

20 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv26142 Modified Files: typep.lisp Log Message: Fixed array type-expander. Date: Sat Aug 20 22:28:32 2005 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.48 movitz/losp/muerte/typep.lisp:1.49 --- movitz/losp/muerte/typep.lisp:1.48 Sun Aug 14 20:52:53 2005 +++ movitz/losp/muerte/typep.lisp Sat Aug 20 22:28:31 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.48 2005/08/14 18:52:53 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.49 2005/08/20 20:28:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -590,10 +590,10 @@ (when (equal xet aet) (return t)))) (or (eq dimension-spec '*) (if (typep dimension-spec 'integer) - (= dimension-spec (array-rank x)) - (and (= (length dimension-spec) (array-rank x)) + (eql dimension-spec (array-rank x)) + (and (eql (length dimension-spec) (array-rank x)) (every (lambda (xdim adim) - (or (eq xdim '*) (= xdim adim))) + (or (eq xdim '*) (eql xdim adim))) dimension-spec (array-dimensions x)))))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/io-port.lisp
by ffjeld＠common-lisp.net 20 Aug '05

20 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv26127 Modified Files: io-port.lisp Log Message: Use check-the in with-io-register-syntax. Date: Sat Aug 20 22:27:19 2005 Author: ffjeld Index: movitz/losp/muerte/io-port.lisp diff -u movitz/losp/muerte/io-port.lisp:1.17 movitz/losp/muerte/io-port.lisp:1.18 --- movitz/losp/muerte/io-port.lisp:1.17 Mon Aug 15 02:06:19 2005 +++ movitz/losp/muerte/io-port.lisp Sat Aug 20 22:27:19 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Mar 21 22:14:08 2001 ;;;; -;;;; $Id: io-port.lisp,v 1.17 2005/08/15 00:06:19 ffjeld Exp $ +;;;; $Id: io-port.lisp,v 1.18 2005/08/20 20:27:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -308,8 +308,7 @@ "Syntax for easy access to IO registers. <name> is installed as a local macro that reads from <io-base-form> plus some offset." (let ((io-var (gensym "io-base-"))) - `(let ((,io-var ,io-base-form)) - ;; (check-type ,io-var (unsigned-byte 16)) + `(let ((,io-var (check-the (unsigned-byte 16) ,io-base-form))) (symbol-macrolet ((,name ,io-var)) (macrolet ((,name (offset &optional (type :unsigned-byte8)) `(io-port (+ ,',io-var ,offset) ,type)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/bignums.lisp
by ffjeld＠common-lisp.net 20 Aug '05

20 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv26107 Modified Files: bignums.lisp Log Message: Add an optional (8-bit) fill parameter to %make-bignum. Date: Sat Aug 20 22:25:41 2005 Author: ffjeld Index: movitz/losp/muerte/bignums.lisp diff -u movitz/losp/muerte/bignums.lisp:1.15 movitz/losp/muerte/bignums.lisp:1.16 --- movitz/losp/muerte/bignums.lisp:1.15 Mon Feb 14 08:13:42 2005 +++ movitz/losp/muerte/bignums.lisp Sat Aug 20 22:25:41 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Jul 17 19:42:57 2004 ;;;; -;;;; $Id: bignums.lisp,v 1.15 2005/02/14 07:13:42 ffjeld Exp $ +;;;; $Id: bignums.lisp,v 1.16 2005/08/20 20:25:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -66,18 +66,29 @@ (check-type old bignum) (%shallow-copy-object old (1+ (%bignum-bigits old)))) -(defun %make-bignum (bigits) - (assert (plusp bigits)) - (macrolet - ((do-it () - `(let ((words (1+ bigits))) - (with-non-pointer-allocation-assembly (words :fixed-size-p t - :object-register :eax) - (:load-lexical (:lexical-binding bigits) :ecx) - (:shll 16 :ecx) - (:orl ,(movitz:tag :bignum 0) :ecx) - (:movl :ecx (:eax (:offset movitz-bignum type))))))) - (do-it))) +(defun %make-bignum (bigits &optional fill) + (numargs-case + (1 (bigits) + (check-type bigits (unsigned-byte 14)) + (macrolet + ((do-it () + `(let ((words (1+ bigits))) + (with-non-pointer-allocation-assembly (words :fixed-size-p t + :object-register :eax) + (:load-lexical (:lexical-binding bigits) :ecx) + (:shll 16 :ecx) + (:orl ,(movitz:tag :bignum 0) :ecx) + (:movl :ecx (:eax (:offset movitz-bignum type))))))) + (do-it))) + (t (bigits &optional fill) + (let ((bignum (%make-bignum bigits))) + (when fill + (check-type fill (unsigned-byte 8)) + (dotimes (i (* 4 bigits)) + (setf (memref bignum (movitz-type-slot-offset 'movitz-bignum 'bigit0) + :index i :type :unsigned-byte8) + fill))) + bignum)))) (defun print-bignum (x) (check-type x bignum)

1 0