movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 16 Mar '07

16 Mar '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv31526 Modified Files: scavenge.lisp Log Message: Fixed nasty bug in map-header-vals: x2 is supposed to be the upper 16 bits of each word, but was really the 'middle' 16 bits (i.e bits 8-24). --- /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2007/03/16 21:12:52 1.57 +++ /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2007/03/16 21:17:55 1.58 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.57 2007/03/16 21:12:52 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.58 2007/03/16 21:17:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -60,7 +60,7 @@ ((>= scan end-location)) (declare (fixnum scan)) (let ((x (memref scan 0 :type :unsigned-byte16)) - (x2 (memref scan 1 :type :unsigned-byte16))) + (x2 (memref scan 2 :type :unsigned-byte16))) (when verbose (format *terminal-io* " [at ~S: ~S]" scan x)) (cond

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 16 Mar '07

16 Mar '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv31042 Modified Files: scavenge.lisp Log Message: Add support for bit-vectors in map-header-vals. --- /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2007/03/16 20:23:21 1.56 +++ /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2007/03/16 21:12:52 1.57 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.56 2007/03/16 20:23:21 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.57 2007/03/16 21:12:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -180,6 +180,14 @@ "Scanned basic-vector at ~S with illegal length ~S." scan len) (record-scan (%word-offset scan #.(movitz:tag :other))) (incf scan (1+ (logand (1+ len) -2))))) + ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :bit)) + (assert (evenp scan) () + "Scanned bit-vector-header ~S at odd location #x~X." x scan) + (let ((len (memref scan 4))) + (assert (typep len 'positive-fixnum) () + "Scanned basic-vector at ~S with illegal length ~S." scan len) + (record-scan (%word-offset scan #.(movitz:tag :other))) + (incf scan (1+ (* 2 (truncate (+ 63 len) 64)))))) ((scavenge-typep x :basic-vector) (if (or (scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 16 Mar '07

16 Mar '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv21201 Modified Files: scavenge.lisp Log Message: Remove rather useless restart in the inner loop of map-header-vals. This speeds up GC quite a bit. --- /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2006/01/07 21:40:12 1.55 +++ /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2007/03/16 20:23:21 1.56 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.55 2006/01/07 21:40:12 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.56 2007/03/16 20:23:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -59,73 +59,71 @@ (scan start-location (1+ scan))) ((>= scan end-location)) (declare (fixnum scan)) - (with-simple-restart (continue-map-header-vals - "Continue map-header-vals at location ~S." (1+ scan)) - (let ((x (memref scan 0 :type :unsigned-byte16)) - (x2 (memref scan 1 :type :unsigned-byte16))) - (when verbose - (format *terminal-io* " [at ~S: ~S]" scan x)) - (cond - ((let ((tag (ldb (byte 3 0) x))) - (or (= tag #.(movitz:tag :null)) - (= tag #.(movitz:tag :even-fixnum)) - (= tag #.(movitz:tag :odd-fixnum)) - (scavenge-typep x :character)))) - ((or (and (= 0 x2) (= 2 x)) - (and (= #xffff x2) (= #xfffe x)) - (and (= #x7fff x2) (= #xffff x)))) - ((scavenge-typep x :illegal) - (error "Illegal word ~S at ~S." x scan)) - ((scavenge-typep x :bignum) - (assert (evenp scan) () - "Scanned bignum-header ~S at odd location #x~X." x scan) - ;; Just skip the bigits - (let* ((bigits (memref scan 0 :index 1 :type :unsigned-byte14)) - (delta (logior bigits 1))) - (record-scan (%word-offset scan #.(movitz:tag :other))) - (incf scan delta))) - ((scavenge-typep x :defstruct) - (assert (evenp scan) () - "Scanned struct-header ~S at odd location #x~X." x scan) - (record-scan (%word-offset scan #.(movitz:tag :other)))) - ((scavenge-typep x :run-time-context) - (assert (evenp scan) () - "Scanned run-time-context-header ~S at odd location #x~X." - (memref scan 0 :type :unsigned-byte32) scan) - (incf scan) - (let ((non-lispvals #.(cl:truncate (cl:+ -4 (bt:slot-offset 'movitz::movitz-run-time-context - 'movitz::pointer-start) - (movitz::image-nil-word movitz:*image*)) - 4)) - (end (+ scan #.(movitz::movitz-type-word-size 'movitz::movitz-run-time-context)))) - (incf scan non-lispvals) - (map-lisp-vals function scan (1+ end)) - (setf scan end))) - ((scavenge-typep x :funobj) - (assert (evenp scan) () - "Scanned funobj-header ~S at odd location #x~X." - (memref scan 0 :type :unsigned-byte32) scan) - (record-scan (%word-offset scan #.(movitz:tag :other))) - ;; Process code-vector pointers specially.. - (let* ((old-code-vector (memref (incf scan) 0 :type :code-vector)) - (new-code-vector (map-instruction-pointer function scan old-code-vector))) - (cond + (let ((x (memref scan 0 :type :unsigned-byte16)) + (x2 (memref scan 1 :type :unsigned-byte16))) + (when verbose + (format *terminal-io* " [at ~S: ~S]" scan x)) + (cond + ((let ((tag (ldb (byte 3 0) x))) + (or (= tag #.(movitz:tag :null)) + (= tag #.(movitz:tag :even-fixnum)) + (= tag #.(movitz:tag :odd-fixnum)) + (scavenge-typep x :character)))) + ((or (and (= 0 x2) (= 2 x)) + (and (= #xffff x2) (= #xfffe x)) + (and (= #x7fff x2) (= #xffff x)))) + ((scavenge-typep x :illegal) + (error "Illegal word ~S at ~S." x scan)) + ((scavenge-typep x :bignum) + (assert (evenp scan) () + "Scanned bignum-header ~S at odd location #x~X." x scan) + ;; Just skip the bigits + (let* ((bigits (memref scan 0 :index 1 :type :unsigned-byte14)) + (delta (logior bigits 1))) + (record-scan (%word-offset scan #.(movitz:tag :other))) + (incf scan delta))) + ((scavenge-typep x :defstruct) + (assert (evenp scan) () + "Scanned struct-header ~S at odd location #x~X." x scan) + (record-scan (%word-offset scan #.(movitz:tag :other)))) + ((scavenge-typep x :run-time-context) + (assert (evenp scan) () + "Scanned run-time-context-header ~S at odd location #x~X." + (memref scan 0 :type :unsigned-byte32) scan) + (incf scan) + (let ((non-lispvals #.(cl:truncate (cl:+ -4 (bt:slot-offset 'movitz::movitz-run-time-context + 'movitz::pointer-start) + (movitz::image-nil-word movitz:*image*)) + 4)) + (end (+ scan #.(movitz::movitz-type-word-size 'movitz::movitz-run-time-context)))) + (incf scan non-lispvals) + (map-lisp-vals function scan (1+ end)) + (setf scan end))) + ((scavenge-typep x :funobj) + (assert (evenp scan) () + "Scanned funobj-header ~S at odd location #x~X." + (memref scan 0 :type :unsigned-byte32) scan) + (record-scan (%word-offset scan #.(movitz:tag :other))) + ;; Process code-vector pointers specially.. + (let* ((old-code-vector (memref (incf scan) 0 :type :code-vector)) + (new-code-vector (map-instruction-pointer function scan old-code-vector))) + (cond ((not (eq new-code-vector old-code-vector)) ;; Code-vector%1op (if (location-in-code-vector-p%unsafe old-code-vector (memref (incf scan) 0 :type :location)) (map-instruction-pointer function scan old-code-vector) - (map-instruction-pointer function scan)) + (map-instruction-pointer function scan)) ;; Code-vector%2op (if (location-in-code-vector-p%unsafe old-code-vector (memref (incf scan) 0 :type :location)) (map-instruction-pointer function scan old-code-vector) - (map-instruction-pointer function scan)) + (map-instruction-pointer function scan)) ;; Code-vector%3op (if (location-in-code-vector-p%unsafe old-code-vector (memref (incf scan) 0 :type :location)) (map-instruction-pointer function scan old-code-vector) - (map-instruction-pointer function scan)) + (map-instruction-pointer function scan)) ;; lambda-list and name (map-header-vals function (incf scan) (incf scan 2)) ;; Jumpers @@ -151,61 +149,61 @@ (let ((num-jumpers (memref scan 0 :type :unsigned-byte14)) #+ignore (num-constants (memref scan 2 :type :unsigned-byte16))) (incf scan num-jumpers)))))) - ((scavenge-typep x :infant-object) - (assert (evenp scan) () - "Scanned infant ~S at odd location #x~X." x scan) - (error "Scanning an infant object ~Z at ~S (end ~S)." x scan end-location)) - ((or (scavenge-wide-typep x :basic-vector - #.(bt:enum-value 'movitz:movitz-vector-element-type :u8)) - (scavenge-wide-typep x :basic-vector - #.(bt:enum-value 'movitz:movitz-vector-element-type :character)) - (scavenge-wide-typep x :basic-vector - #.(bt:enum-value 'movitz:movitz-vector-element-type :code))) - (assert (evenp scan) () - "Scanned u8-vector-header ~S at odd location #x~X." x scan) - (let ((len (memref scan 0 :index 1 :type :lisp))) - (check-type len positive-fixnum) - (record-scan (%word-offset scan #.(movitz:tag :other))) - (incf scan (1+ (* 2 (truncate (+ 7 len) 8)))))) - ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16)) - (assert (evenp scan) () - "Scanned u16-vector-header ~S at odd location #x~X." x scan) - (let ((len (memref scan 0 :index 1))) - (check-type len positive-fixnum) - (record-scan (%word-offset scan #.(movitz:tag :other))) - (incf scan (1+ (* 2 (truncate (+ 3 len) 4)))))) - ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32)) - (assert (evenp scan) () - "Scanned u32-vector-header ~S at odd location #x~X." x scan) - (let ((len (memref scan 4))) - (assert (typep len 'positive-fixnum) () - "Scanned basic-vector at ~S with illegal length ~S." scan len) - (record-scan (%word-offset scan #.(movitz:tag :other))) - (incf scan (1+ (logand (1+ len) -2))))) - ((scavenge-typep x :basic-vector) - (if (or (scavenge-wide-typep x :basic-vector - #.(bt:enum-value 'movitz:movitz-vector-element-type - :any-t)) - (scavenge-wide-typep x :basic-vector - #.(bt:enum-value 'movitz:movitz-vector-element-type - :indirects))) - (record-scan (%word-offset scan #.(movitz:tag :other))) - (error "Scanned unknown basic-vector-header ~S at location #x~X." x scan))) - ((and (eq x 3) (eq x2 0)) - (record-scan scan) - (incf scan) - (let ((delta (memref scan 0))) - (check-type delta positive-fixnum) - ;; (warn "at ~S skipping ~S to ~S." scan delta (+ scan delta)) - (incf scan delta))) - (t ;; (typep x 'pointer) - (let ((old (memref scan 0))) - (unless (eq old (load-global-constant new-unbound-value)) - (let ((new (funcall function old scan))) - (when verbose - (format *terminal-io* " [~Z => ~Z]" old new)) - (unless (eq old new) - (setf (memref scan 0) new))))))))))) + ((scavenge-typep x :infant-object) + (assert (evenp scan) () + "Scanned infant ~S at odd location #x~X." x scan) + (error "Scanning an infant object ~Z at ~S (end ~S)." x scan end-location)) + ((or (scavenge-wide-typep x :basic-vector + #.(bt:enum-value 'movitz:movitz-vector-element-type :u8)) + (scavenge-wide-typep x :basic-vector + #.(bt:enum-value 'movitz:movitz-vector-element-type :character)) + (scavenge-wide-typep x :basic-vector + #.(bt:enum-value 'movitz:movitz-vector-element-type :code))) + (assert (evenp scan) () + "Scanned u8-vector-header ~S at odd location #x~X." x scan) + (let ((len (memref scan 0 :index 1 :type :lisp))) + (check-type len positive-fixnum) + (record-scan (%word-offset scan #.(movitz:tag :other))) + (incf scan (1+ (* 2 (truncate (+ 7 len) 8)))))) + ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16)) + (assert (evenp scan) () + "Scanned u16-vector-header ~S at odd location #x~X." x scan) + (let ((len (memref scan 0 :index 1))) + (check-type len positive-fixnum) + (record-scan (%word-offset scan #.(movitz:tag :other))) + (incf scan (1+ (* 2 (truncate (+ 3 len) 4)))))) + ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32)) + (assert (evenp scan) () + "Scanned u32-vector-header ~S at odd location #x~X." x scan) + (let ((len (memref scan 4))) + (assert (typep len 'positive-fixnum) () + "Scanned basic-vector at ~S with illegal length ~S." scan len) + (record-scan (%word-offset scan #.(movitz:tag :other))) + (incf scan (1+ (logand (1+ len) -2))))) + ((scavenge-typep x :basic-vector) + (if (or (scavenge-wide-typep x :basic-vector + #.(bt:enum-value 'movitz:movitz-vector-element-type + :any-t)) + (scavenge-wide-typep x :basic-vector + #.(bt:enum-value 'movitz:movitz-vector-element-type + :indirects))) + (record-scan (%word-offset scan #.(movitz:tag :other))) + (error "Scanned unknown basic-vector-header ~S at location #x~X." x scan))) + ((and (eq x 3) (eq x2 0)) + (record-scan scan) + (incf scan) + (let ((delta (memref scan 0))) + (check-type delta positive-fixnum) + ;; (warn "at ~S skipping ~S to ~S." scan delta (+ scan delta)) + (incf scan delta))) + (t ;; (typep x 'pointer) + (let ((old (memref scan 0))) + (unless (eq old (load-global-constant new-unbound-value)) + (let ((new (funcall function old scan))) + (when verbose + (format *terminal-io* " [~Z => ~Z]" old new)) + (unless (eq old new) + (setf (memref scan 0) new)))))))))) (values)) (defun map-stack-vector (function stack start-frame &optional (map-region #'map-header-vals))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 16 Mar '07

16 Mar '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv12470 Modified Files: inspect.lisp Log Message: In shallow-copy use %make-ratio rather than make-ratio, because the numerator and/or denominator might be inconsistent when the copy is being made (i.e. during GC). This caused GC across ratios to fail. --- /project/movitz/cvsroot/movitz/losp/muerte/inspect.lisp 2005/10/25 19:26:47 1.57 +++ /project/movitz/cvsroot/movitz/losp/muerte/inspect.lisp 2007/03/16 19:50:47 1.58 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.57 2005/10/25 19:26:47 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.58 2007/03/16 19:50:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -263,8 +263,8 @@ (structure-object (copy-structure old)) (ratio - (make-ratio (%ratio-numerator old) - (%ratio-denominator old))) + (%make-ratio (%ratio-numerator old) + (%ratio-denominator old))) (run-time-context (%shallow-copy-object old (movitz-type-word-size 'movitz-run-time-context)))))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 16 Mar '07

16 Mar '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv12162 Modified Files: ratios.lisp Log Message: Factor out %make-ratio from make-ratio. --- /project/movitz/cvsroot/movitz/losp/muerte/ratios.lisp 2007/03/16 17:41:11 1.8 +++ /project/movitz/cvsroot/movitz/losp/muerte/ratios.lisp 2007/03/16 19:49:24 1.9 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 20 00:39:59 2004 ;;;; -;;;; $Id: ratios.lisp,v 1.8 2007/03/16 17:41:11 ffjeld Exp $ +;;;; $Id: ratios.lisp,v 1.9 2007/03/16 19:49:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -21,9 +21,7 @@ (in-package muerte) -(defun make-ratio (numerator denominator) - (check-type numerator integer) - (check-type denominator (integer 1 *)) +(defun %make-ratio (numerator denominator) (macrolet ((do-it () `(with-allocation-assembly (4 :fixed-size-p t @@ -36,6 +34,11 @@ (:movl :edx (:eax (:offset movitz-ratio denominator)))))) (do-it))) +(defun make-ratio (numerator denominator) + (check-type numerator integer) + (check-type denominator (integer 1 *)) + (%make-ratio numerator denominator)) + (defun ratio-p (x) (typep x 'ratio))

1 0

[movitz-cvs] CVS movitz
by ffjeld 16 Mar '07

16 Mar '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv18485 Modified Files: compiler.lisp Log Message: The compiler used to fail upon lending of constant bindings. Fixed. --- /project/movitz/cvsroot/movitz/compiler.lisp 2007/03/16 17:47:27 1.183 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2007/03/16 18:03:09 1.184 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.183 2007/03/16 17:47:27 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.184 2007/03/16 18:03:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -620,43 +620,45 @@ (check-type toplevel-funobj movitz-funobj) (let ((function-binding-usage ())) (labels ((process-binding (funobj binding usages) - (if (not (eq funobj (binding-funobj binding))) - (let ((borrowing-binding - (or (find binding (borrowed-bindings funobj) - :key #'borrowed-binding-target) - (car (push (movitz-env-add-binding (funobj-env funobj) - (make-instance 'borrowed-binding - :name (binding-name binding) - :target-binding binding)) - (borrowed-bindings funobj)))))) - ;; We don't want to borrow a forwarding-binding.. - (when (typep (borrowed-binding-target borrowing-binding) - 'forwarding-binding) - (change-class (borrowed-binding-target borrowing-binding) - 'located-binding)) + (cond + ((typep binding 'constant-object-binding)) + ((not (eq funobj (binding-funobj binding))) + (let ((borrowing-binding + (or (find binding (borrowed-bindings funobj) + :key #'borrowed-binding-target) + (car (push (movitz-env-add-binding (funobj-env funobj) + (make-instance 'borrowed-binding + :name (binding-name binding) + :target-binding binding)) + (borrowed-bindings funobj)))))) + ;; We don't want to borrow a forwarding-binding.. + (when (typep (borrowed-binding-target borrowing-binding) + 'forwarding-binding) + (change-class (borrowed-binding-target borrowing-binding) + 'located-binding)) ;;; (warn "binding ~S of ~S is not local to ~S, replacing with ~S of ~S." ;;; binding (binding-env binding) funobj ;;; borrowing-binding (binding-env borrowing-binding)) ;;; (pushnew borrowing-binding ;;; (getf (binding-lended-p binding) :lended-to)) - (dolist (usage usages) - (pushnew usage (borrowed-binding-usage borrowing-binding))) - borrowing-binding) - ;; 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 - (dolist (usage usages) - (pushnew usage - (getf (sub-function-binding-usage (function-binding-parent binding)) - binding)) - (pushnew usage (getf function-binding-usage binding))) - binding) - (t binding)))) + (dolist (usage usages) + (pushnew usage (borrowed-binding-usage borrowing-binding))) + borrowing-binding)) + (t ; 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 + (dolist (usage usages) + (pushnew usage + (getf (sub-function-binding-usage (function-binding-parent binding)) + binding)) + (pushnew usage (getf function-binding-usage binding))) + binding) + (t binding))))) (resolve-sub-funobj (funobj sub-funobj) (dolist (binding-we-lend (borrowed-bindings (resolve-funobj-borrowing sub-funobj))) #+ignore @@ -6405,16 +6407,16 @@ (defun ensure-local-binding (binding funobj) "When referencing binding in funobj, ensure we have the binding local to funobj." - (if (not (typep binding 'binding)) - binding - (let ((target-binding (binding-target binding))) - (cond - ((eq funobj (binding-funobj target-binding)) - binding) - (t (or (find target-binding (borrowed-bindings funobj) - :key (lambda (binding) - (borrowed-binding-target binding))) - (error "Can't install non-local binding ~W." binding))))))) + (if (typep binding '(or (not binding) constant-object-binding)) + binding ; Never mind if "binding" isn't a binding, or is a constant-binding. + (let ((target-binding (binding-target binding))) + (cond + ((eq funobj (binding-funobj target-binding)) + binding) + (t (or (find target-binding (borrowed-bindings funobj) + :key (lambda (binding) + (borrowed-binding-target binding))) + (error "Can't install non-local binding ~W." binding))))))) (defun binding-store-subtypep (binding type-specifier) "Is type-specifier a supertype of all values ever stored to binding?

1 0

[movitz-cvs] CVS movitz
by ffjeld 16 Mar '07

16 Mar '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv14567 Modified Files: compiler.lisp Log Message: Removed some dead code. --- /project/movitz/cvsroot/movitz/compiler.lisp 2007/03/11 22:40:57 1.182 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2007/03/16 17:47:27 1.183 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.182 2007/03/11 22:40:57 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.183 2007/03/16 17:47:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5986,26 +5986,7 @@ :code nil :final-form binding :returns binding - :functional-p t)) - #+ignore - (t (let ((returns (ecase (result-mode-type result-mode) - ((:function :multiple-values :eax) - :eax) - (:lexical-binding - result-mode) - ((:ebx :ecx :edx :esi :push - ;; :untagged-fixnum-eax - :untagged-fixnum-ecx - :boolean-branch-on-true - :boolean-branch-on-false) - result-mode) - (:boolean - :boolean=zf=0)))) - (compiler-values () - :code (make-compiled-lexical-load binding returns) - :final-form binding - :returns returns - :functional-p t)))))) + :functional-p t))))) (defun make-compiled-lexical-load (binding result-mode &rest key-args) "Do what is necessary to load lexical binding <binding>." @@ -6131,13 +6112,6 @@ :type nil)) (t (compiler-values (self-eval) :returns binding)))))) -;;; ((:eax :single-value :multiple-values :function) -;;; (compiler-values (self-eval) -;;; :code `((:load-lexical ,binding :eax)) -;;; :returns :eax)) -;;; (t (compiler-values (self-eval) -;;; :code `((:load-lexical ,binding ,result-mode)) -;;; :returns result-mode)))))) (define-compiler compile-implicit-progn (&all all &form forms &top-level-p top-level-p &result-mode result-mode) @@ -6563,14 +6537,7 @@ (cond ((not (new-binding-located-p binding frame-map)) (unless (or (movitz-env-get (binding-name binding) 'ignore nil (binding-env binding)) - (movitz-env-get (binding-name binding) 'ignorable nil (binding-env binding)) - #+ignore - (labels ((recursive-located-p (b) - (or (new-binding-located-p b frame-map) - (and (typep binding 'forwarding-binding) - (recursive-located-p (forwarding-binding-target b)))))) - (recursive-located-p binding))) - #+ignore (warn "Unused variable: ~S." (binding-name binding)))) + (movitz-env-get (binding-name binding) 'ignorable nil (binding-env binding))))) ((typep binding 'forwarding-binding) ;; No need to do any initialization because the target will be initialized. (assert (not (binding-lended-p binding)))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 16 Mar '07

16 Mar '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv13546 Modified Files: ratios.lisp Log Message: Add some faux constants. --- /project/movitz/cvsroot/movitz/losp/muerte/ratios.lisp 2004/09/22 17:52:08 1.7 +++ /project/movitz/cvsroot/movitz/losp/muerte/ratios.lisp 2007/03/16 17:41:11 1.8 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 20 00:39:59 2004 ;;;; -;;;; $Id: ratios.lisp,v 1.7 2004/09/22 17:52:08 ffjeld Exp $ +;;;; $Id: ratios.lisp,v 1.8 2007/03/16 17:41:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -74,3 +74,8 @@ (ratio (%ratio-denominator x)))) (defconstant pi #xea7632a/4aa1a8b) + +(defconstant least-positive-short-float 1/1000) +(defconstant least-positive-single-float 1/1000) +(defconstant least-positive-double-float 1/1000) +(defconstant least-positive-long-float 1/1000)

1 0

[movitz-cvs] CVS movitz
by ffjeld 16 Mar '07

16 Mar '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv13497 Modified Files: image.lisp Log Message: Add qemu-align-p argument to dump-image. When true, pad (floppy) image such that QEMU's (rather stupid) floppy geometry auto-detection will work. --- /project/movitz/cvsroot/movitz/image.lisp 2007/03/13 20:40:06 1.111 +++ /project/movitz/cvsroot/movitz/image.lisp 2007/03/16 17:40:43 1.112 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.111 2007/03/13 20:40:06 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.112 2007/03/16 17:40:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -843,7 +843,7 @@ (values)) (defun dump-image (&key (path *default-image-file*) ((:image *image*) *image*) - (multiboot-p t) ignore-dump-count) + (multiboot-p t) ignore-dump-count (qemu-align-p t)) "When <multiboot-p> is true, include a MultiBoot-compliant header in the image." (when (and (not ignore-dump-count) (= 0 (dump-count *image*))) @@ -934,7 +934,7 @@ (warn "non-used setf: ~S" v))) ;; symbol plists (loop for (symbol plist) on (movitz-environment-plists *movitz-global-environment*) by #'cddr - ;; do (warn "sp: ~S ~S" symbol plist) + ;; do (warn "sp: ~S ~S" symbol plist) do (let ((x (movitz-read symbol))) (typecase x (movitz-null) @@ -974,9 +974,24 @@ (image-end (file-position stream)) (kernel-size (- image-end image-start))) (format t "~&;; Kernel size: ~D octets.~%" kernel-size) - (unless (zerop (mod image-end 512)) ; Ensure image is multiple of 512 octets - (set-file-position stream (+ image-end (- 511 (mod image-end 512))) 'pad-image-tail) - (write-byte #x0 stream)) + (cond + (qemu-align-p + ;; QEMU is rather stupid about "auto-detecting" floppy geometries. + (loop for qemu-geo in '(320 360 640 720 720 820 840 1440 1440 1600 1640 1660 1760 2080 2240 2400 + 2880 2952 2988 3200 3200 3360 3444 3486 3520 3680 3840 5760 6240 6400 7040 7680) + as qemu-size = (* qemu-geo 512) + do (when (>= qemu-size image-end) + (set-file-position stream (1- qemu-size) 'pad-image-tail) + (write-byte #x0 stream) + (return)) + finally + (cerror "Never mind, dump the image." + "No matching QEMU floppy geometry for size ~,2F MB." (/ image-end (* 1024 1024))))) + (t (let ((align-image-size 512)) ; Ensure image is multiple of x octets + (unless (zerop (mod image-end align-image-size)) + (set-file-position stream (+ image-end (- (1- align-image-size) (mod image-end 512))) + 'pad-image-tail) + (write-byte #x0 stream))))) (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*)))

1 0

[movitz-cvs] CVS movitz
by ffjeld 16 Mar '07

16 Mar '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv11805 Modified Files: bootblock.lisp Log Message: Be more supportive of floppy geometries other than 1.44 MB. --- /project/movitz/cvsroot/movitz/bootblock.lisp 2007/03/11 22:40:16 1.12 +++ /project/movitz/cvsroot/movitz/bootblock.lisp 2007/03/16 17:39:27 1.13 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Oct 9 20:47:19 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: bootblock.lisp,v 1.12 2007/03/11 22:40:16 ffjeld Exp $ +;;;; $Id: bootblock.lisp,v 1.13 2007/03/16 17:39:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -26,6 +26,7 @@ *bootblock-build-file*) 0)) +(defvar *floppy-size* (* 512 18 2 80)) (defun make-segment-descriptor-byte (&rest descriptor-args) (list (complex (binary-types::bitfield-compute-numeric-value @@ -82,8 +83,6 @@ (let* ((first-sector (1+ skip-sectors)) (last-sector (+ first-sector (ceiling image-size +sector-size+))) (read-buffer-segment (floor +read-buffer+ #x10))) - (assert (<= last-sector (* 2 18 80)) () - "Image too large for 1.44 floppy geometry.") (ia-x86:read-proglist `( (:jmp (:pc+ 0)) ; some BIOSes might check for this. @@ -402,12 +401,14 @@ (defun make-bootblock (image-size load-address call-address &key (skip-sectors 0) (include-records)) - (let ((floppy-room (- (* 512 18 2 80) 512))) ; Size of floppy minus the bootloader. - (if (> image-size floppy-room) - (error "The image is ~D bytes too big to fit on a floppy." - (- image-size floppy-room)) - (format t "~&;; Bootloader has room for ~,1F KB more." - (/ (- floppy-room image-size) 1024)))) + (when *floppy-size* + (let ((floppy-room (- *floppy-size* 512))) ; Size of floppy minus the bootloader. + (if (> image-size floppy-room) + (warn "The image is ~D bytes too big to fit on a ~,2F MB floppy." + (- image-size floppy-room) + (/ *floppy-size* (* 1024 1000))) + (format t "~&;; Bootloader has room for ~,1F KB more." + (/ (- floppy-room image-size) 1024))))) (multiple-value-bind (bios-loader bb-symtab) (ia-x86:proglist-encode :octet-vector :16-bit #x7c00 (mkasm16-bios-bootloader image-size load-address skip-sectors))

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs