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

[movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp
by Frode Vatvedt Fjeld 16 Jul '04

16 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv14528 Modified Files: inspect.lisp Log Message: Do a bit more safety checking in %bignum-canonicalize and %make-bignum. Date: Fri Jul 16 03:43:26 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.22 movitz/losp/muerte/inspect.lisp:1.23 --- movitz/losp/muerte/inspect.lisp:1.22 Thu Jul 15 17:02:03 2004 +++ movitz/losp/muerte/inspect.lisp Fri Jul 16 03:43:26 2004 @@ -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.22 2004/07/16 00:02:03 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.23 2004/07/16 10:43:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -265,12 +265,15 @@ "Assuming x is a bignum, return the canonical integer value. That is, either return a fixnum, or destructively modify the bignum's length so that the msb isn't zero. DO NOT APPLY TO NON-BIGNUM VALUES!" + (check-type x bignum) (macrolet ((do-it () `(with-inline-assembly (:returns :eax) (:load-lexical (:lexical-binding x) :eax) (:movl (:eax ,movitz:+other-type-offset+) :ecx) (:shrl 16 :ecx) + (:jz '(:sub-program (should-never-happen) + (:int 107))) shrink-loop (:cmpl ,movitz:+movitz-fixnum-factor+ :ecx) (:je 'shrink-no-more) @@ -308,6 +311,7 @@ (:jnc 'copy-bignum-loop)))) (defun %make-bignum (bigits) + (assert (plusp bigits)) (macrolet ((do-it () `(with-inline-assembly (:returns :eax)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 16 Jul '04

16 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12224 Modified Files: integers.lisp Log Message: Fixed a nasty bug in ash which failed to handle the situation when a bignum got shifted to zero. Also fixed a bug in truncate on negatives. Date: Fri Jul 16 03:42:41 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.67 movitz/losp/muerte/integers.lisp:1.68 --- movitz/losp/muerte/integers.lisp:1.67 Thu Jul 15 17:03:05 2004 +++ movitz/losp/muerte/integers.lisp Fri Jul 16 03:42:40 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.67 2004/07/16 00:03:05 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.68 2004/07/16 10:42:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1133,21 +1133,23 @@ (:andl -4 :eax) (:cld))) (positive-bignum - (let* ((result-length (- (integer-length integer) count)) - (result (%make-bignum (truncate (+ result-length 31) 32)))) - (multiple-value-bind (long short) - (truncate count 16) - (let ((src-max-bigit (* 2 (%bignum-bigits integer)))) - (dotimes (i (* 2 (%bignum-bigits result))) - (let ((src (+ i long))) - (setf (memref result -2 i :unsigned-byte16) - (if (< src src-max-bigit) - (memref integer -2 src :unsigned-byte16) - 0))))) - (setf result (%bignum-canonicalize result)) - (dotimes (i short result) - (setf result (truncate result 2))) - result)))))))) + (let ((result-length (- (integer-length integer) count))) + (if (<= result-length 0) + 0 + (let ((result (%make-bignum (truncate (+ result-length 31) 32)))) + (multiple-value-bind (long short) + (truncate count 16) + (let ((src-max-bigit (* 2 (%bignum-bigits integer)))) + (dotimes (i (* 2 (%bignum-bigits result))) + (let ((src (+ i long))) + (setf (memref result -2 i :unsigned-byte16) + (if (< src src-max-bigit) + (memref integer -2 src :unsigned-byte16) + 0))))) + (setf result (%bignum-canonicalize result)) + (dotimes (i short result) + (setf result (truncate result 2))) + result)))))))))) ;;;; @@ -1540,12 +1542,12 @@ (%negatef r number divisor)))) (((integer 0 *) (integer * -1)) (multiple-value-bind (q r) - (truncate (- number) divisor) + (truncate number (- divisor)) (values (%negatef q number divisor) r))) (((integer * -1) (integer * -1)) (multiple-value-bind (q r) - (truncate (- number) divisor) + (truncate (- number) (- divisor)) (values q (%negatef r number divisor)))) ))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp
by Frode Vatvedt Fjeld 16 Jul '04

16 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16497 Modified Files: memref.lisp Log Message: Fixed a bug in the compiler-macro for (setf memref <negative> <x> :unsigned-byte32). Date: Fri Jul 16 03:06:36 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.16 movitz/losp/muerte/memref.lisp:1.17 --- movitz/losp/muerte/memref.lisp:1.16 Thu Jul 15 14:07:18 2004 +++ movitz/losp/muerte/memref.lisp Fri Jul 16 03:06:36 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.16 2004/07/15 21:07:18 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.17 2004/07/16 10:06:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -352,7 +352,7 @@ (:compile-two-forms (:eax :edx) ,index-var ,offset-var) (:load-lexical (:lexical-binding ,object-var) :ebx) (:std) - (:shrl ,movitz::+movitz-fixnum-shift+ :edx) + (:sarl ,movitz::+movitz-fixnum-shift+ :edx) (:addl :eax :edx) ; EDX = offset+index (:movl :ecx (:ebx :edx)) (:movl :edi :edx)

1 0

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

16 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv5830 Modified Files: compiler.lisp Log Message: *** empty log message *** Date: Thu Jul 15 17:03:43 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.75 movitz/compiler.lisp:1.76 --- movitz/compiler.lisp:1.75 Tue Jul 13 15:41:06 2004 +++ movitz/compiler.lisp Thu Jul 15 17:03:42 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.75 2004/07/13 22:41:06 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.76 2004/07/16 00:03:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2347,6 +2347,9 @@ (shadowing-variable :initarg :shadowing-variable :reader shadowing-variable))) + +(defmethod binding-store-type ((binding dynamic-binding)) + (multiple-value-list (type-specifier-encode t))) (defun stack-frame-offset (stack-frame-position) (* -4 (1+ stack-frame-position)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 16 Jul '04

16 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2747 Modified Files: integers.lisp Log Message: Improved ash. Fixed a bug wrt. carry-propagation in - for bignums. Date: Thu Jul 15 17:03:05 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.66 movitz/losp/muerte/integers.lisp:1.67 --- movitz/losp/muerte/integers.lisp:1.66 Thu Jul 15 14:07:08 2004 +++ movitz/losp/muerte/integers.lisp Thu Jul 15 17:03:05 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.66 2004/07/15 21:07:08 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.67 2004/07/16 00:03:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -516,8 +516,11 @@ (:jne 'sub-loop) (:subl :ecx (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) - (:jc '(:sub-program (should-not-happen) - (:int 107))) + (:jnc 'bignum-sub-done) + propagate-carry + (:addl 4 :edx) + (:subl 1 (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:jc 'propagate-carry) bignum-sub-done ))))) (((integer 0 *) (integer * -1)) @@ -1088,14 +1091,63 @@ (defun ash (integer count) (cond - ((not (minusp count)) - (do () ((< count 16)) - (setf integer (no-macro-call * #x10000 integer)) - (decf count 16)) - (dotimes (i count integer) - (setf integer (no-macro-call * 2 integer)))) - (t (dotimes (i (- count) integer) - (setf integer (truncate integer 2)))))) + ((= 0 count) + integer) + ((plusp count) + (let ((result-length (+ (integer-length integer) count))) + (cond + ((<= result-length 29) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ecx) integer count) + (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) + (:shll :cl :eax))) + (t (check-type integer (integer 0 *)) + (multiple-value-bind (long short) + (truncate count 16) + (let ((result (%make-bignum (truncate (+ result-length 31) 32)))) + (dotimes (i long) + (setf (memref result -2 i :unsigned-byte16) 0)) + (etypecase integer + (fixnum + (when (>= integer #x10000) + (setf (memref result -2 (1+ long) :unsigned-byte16) + (ldb (byte 16 16) integer))) + (setf (memref result -2 long :unsigned-byte16) + (ldb (byte 16 0) integer))) + (bignum + (dotimes (i (* 2 (%bignum-bigits integer))) + (setf (memref result -2 (+ i long) :unsigned-byte16) + (memref integer -2 i :unsigned-byte16))))) + (setf result (%bignum-canonicalize result)) + (dotimes (i short) + (setf result (* 2 result))) + result)))))) + (t (let ((count (- count))) + (etypecase integer + (fixnum + (with-inline-assembly (:returns :eax :type fixnum) + (:compile-two-forms (:eax :ecx) integer count) + (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) + (:std) + (:sarl :cl :eax) + (:andl -4 :eax) + (:cld))) + (positive-bignum + (let* ((result-length (- (integer-length integer) count)) + (result (%make-bignum (truncate (+ result-length 31) 32)))) + (multiple-value-bind (long short) + (truncate count 16) + (let ((src-max-bigit (* 2 (%bignum-bigits integer)))) + (dotimes (i (* 2 (%bignum-bigits result))) + (let ((src (+ i long))) + (setf (memref result -2 i :unsigned-byte16) + (if (< src src-max-bigit) + (memref integer -2 src :unsigned-byte16) + 0))))) + (setf result (%bignum-canonicalize result)) + (dotimes (i short result) + (setf result (truncate result 2))) + result)))))))) ;;;; @@ -1317,10 +1369,16 @@ ;; X is the biggest factor. (let ((r 0) (f 0)) (dotimes (half-bigit (* 2 (%bignum-bigits y))) - (setf r (+ r (ash (* (memref y -2 half-bigit :unsigned-byte16) x) - f))) + (incf r (ash (* (memref y -2 half-bigit :unsigned-byte16) x) + f)) (incf f 16)) - r)))))) + r))) + ((t (integer * -1)) + (%negatef (* x (- y)) x y)) + (((integer * -1) t) + (%negatef (* (- x) y) x y)) + (((integer * -1) (integer * -1)) + (* (- x) (- y)))))) (do-it))) (t (&rest factors) (declare (dynamic-extent factors)) @@ -1461,18 +1519,15 @@ (setf msb (+ (* #x10000 msb) (* #x100 (memref divisor -2 (1+ msb-pos) :unsigned-byte8)) (memref divisor -2 msb-pos :unsigned-byte8))) - (multiple-value-bind (long-shift short-shift) - ;; This shifting stuff should be replaced by ash, - ;; when ash is properly implemented. - (truncate msb-pos 3) + (let ((guess-shift (- (* msb-pos 8)))) (do ((msb+1 (1+ msb)) (q 0) (r number)) ((< r divisor) (values q r)) - (let ((guess (truncate r msb+1))) - (dotimes (i long-shift) - (setf guess (truncate guess #x1000000))) - (dotimes (i short-shift) - (setf guess (truncate guess #x100))) + (let ((guess (ash (truncate r msb+1) guess-shift))) +;;; (dotimes (i long-shift) +;;; (setf guess (truncate guess #x1000000))) +;;; (dotimes (i short-shift) +;;; (setf guess (truncate guess #x100))) (if (= 0 guess) (setf q (1+ q) r (- r divisor))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp
by Frode Vatvedt Fjeld 16 Jul '04

16 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27424 Modified Files: inspect.lisp Log Message: Added %make-bignum. Date: Thu Jul 15 17:02:03 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.21 movitz/losp/muerte/inspect.lisp:1.22 --- movitz/losp/muerte/inspect.lisp:1.21 Thu Jul 15 14:07:04 2004 +++ movitz/losp/muerte/inspect.lisp Thu Jul 15 17:02:03 2004 @@ -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.21 2004/07/15 21:07:04 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.22 2004/07/16 00:02:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -306,6 +306,16 @@ (:movl :ecx (:eax :edx #.movitz:+other-type-offset+)) (:subl 4 :edx) (:jnc 'copy-bignum-loop)))) + +(defun %make-bignum (bigits) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ecx) (malloc-non-pointer-words (1+ bigits)) bigits) + (:shll 16 :ecx) + (:orl ,(movitz:tag :bignum 0) :ecx) + (:movl :ecx (:eax ,movitz:+other-type-offset+))))) + (do-it))) (defun print-bignum (x) (check-type x bignum)

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/memory.lisp
by Frode Vatvedt Fjeld 15 Jul '04

15 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv29726 Modified Files: memory.lisp Log Message: This rather substantial check-in is a clean-up of all things related to dynamic memory allocation. In particular, the separation between the muerte kernel with its 'default' memory management (which simply allocates objects consecutively until it runs out) and the los0 GC implementation is improved. Date: Thu Jul 15 14:07:36 2004 Author: ffjeld Index: movitz/losp/x86-pc/memory.lisp diff -u movitz/losp/x86-pc/memory.lisp:1.3 movitz/losp/x86-pc/memory.lisp:1.4 --- movitz/losp/x86-pc/memory.lisp:1.3 Mon Jan 19 03:23:52 2004 +++ movitz/losp/x86-pc/memory.lisp Thu Jul 15 14:07:36 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Oct 11 16:32:11 2001 ;;;; -;;;; $Id: memory.lisp,v 1.3 2004/01/19 11:23:52 ffjeld Exp $ +;;;; $Id: memory.lisp,v 1.4 2004/07/15 21:07:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -20,6 +20,7 @@ (in-package muerte.x86-pc) (defun memory-size () + "Return memory size in megabytes." (let ((kilobyte-memsize (+ #x400 (prog1 @@ -30,4 +31,4 @@ (progn (setf (io-port #x70 :unsigned-byte8) #x17) (io-port #x71 :unsigned-byte8))))))) - (truncate kilobyte-memsize 1024))) + (values (truncate kilobyte-memsize 1024))))

1 0

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

15 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv29617 Modified Files: symbols.lisp Log Message: This rather substantial check-in is a clean-up of all things related to dynamic memory allocation. In particular, the separation between the muerte kernel with its 'default' memory management (which simply allocates objects consecutively until it runs out) and the los0 GC implementation is improved. Date: Thu Jul 15 14:07:32 2004 Author: ffjeld Index: movitz/losp/muerte/symbols.lisp diff -u movitz/losp/muerte/symbols.lisp:1.16 movitz/losp/muerte/symbols.lisp:1.17 --- movitz/losp/muerte/symbols.lisp:1.16 Tue Jul 13 07:06:56 2004 +++ movitz/losp/muerte/symbols.lisp Thu Jul 15 14:07:32 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 23:55:41 2001 ;;;; -;;;; $Id: symbols.lisp,v 1.16 2004/07/13 14:06:56 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.17 2004/07/15 21:07:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,14 +28,14 @@ (symbol (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) symbol) - (:call-global-constant dynamic-load))))) + (:call-local-pf dynamic-load))))) (defun %unbounded-symbol-value (symbol) "Return the symbol's value without checking if it's bound or not." (check-type symbol symbol) (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) symbol) - (:call-global-constant dynamic-find-binding) + (:call-local-pf dynamic-find-binding) (:jnc 'no-local-binding) (:movl (:eax) :eax) (:jmp 'done) @@ -51,7 +51,7 @@ (with-inline-assembly (:returns :ebx) (:compile-form (:result-mode :eax) symbol) (:compile-form (:result-mode :ebx) value) - (:call-global-constant dynamic-store))))) + (:call-local-pf dynamic-store))))) (defun set (symbol value) (setf (symbol-value symbol) value)) @@ -147,7 +147,7 @@ (flags 0)) (eval-when (:compile-toplevel) (assert (= 1 (- (movitz:tag :symbol) (movitz:tag :other))))) - (let ((symbol (%word-offset (malloc-clumps 3) 1))) + (let ((symbol (%word-offset (malloc-pointer-words 6) 1))) (setf-movitz-accessor (symbol movitz-symbol package) package) (setf-movitz-accessor (symbol movitz-symbol name) name) (setf (memref symbol #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::hash-key) @@ -170,7 +170,7 @@ (if (or (eq nil symbol) (not copy-properties)) (%create-symbol (symbol-name symbol)) - (let ((x (%word-offset (malloc-clumps 3) 1))) + (let ((x (%word-offset (malloc-pointer-words 6) 1))) (dotimes (i 6) (setf (memref x #.(cl:- (movitz:tag :symbol)) i :lisp) (memref symbol #.(cl:- (movitz:tag :symbol)) i :lisp)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp
by Frode Vatvedt Fjeld 15 Jul '04

15 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv29355 Modified Files: run-time-context.lisp Log Message: This rather substantial check-in is a clean-up of all things related to dynamic memory allocation. In particular, the separation between the muerte kernel with its 'default' memory management (which simply allocates objects consecutively until it runs out) and the los0 GC implementation is improved. Date: Thu Jul 15 14:07:27 2004 Author: ffjeld Index: movitz/losp/muerte/run-time-context.lisp diff -u movitz/losp/muerte/run-time-context.lisp:1.8 movitz/losp/muerte/run-time-context.lisp:1.9 --- movitz/losp/muerte/run-time-context.lisp:1.8 Thu Jul 15 04:17:02 2004 +++ movitz/losp/muerte/run-time-context.lisp Thu Jul 15 14:07:27 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 12 18:33:02 2003 ;;;; -;;;; $Id: run-time-context.lisp,v 1.8 2004/07/15 11:17:02 ffjeld Exp $ +;;;; $Id: run-time-context.lisp,v 1.9 2004/07/15 21:07:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -132,8 +132,7 @@ (defun clone-run-time-context (&key (parent (current-run-time-context)) (name :anonymous)) (check-type parent run-time-context) - (let ((context (inline-malloc #.(bt:sizeof 'movitz::movitz-constant-block) - :other-tag :run-time-context))) + (let ((context (malloc-pointer-words #.(cl:truncate (bt:sizeof 'movitz::movitz-constant-block) 4)))) (memcopy context parent -6 0 0 #.(bt:sizeof 'movitz::movitz-constant-block) :unsigned-byte8) (setf (%run-time-context-slot 'name context) name

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp
by Frode Vatvedt Fjeld 15 Jul '04

15 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv28224 Modified Files: primitive-functions.lisp Log Message: This rather substantial check-in is a clean-up of all things related to dynamic memory allocation. In particular, the separation between the muerte kernel with its 'default' memory management (which simply allocates objects consecutively until it runs out) and the los0 GC implementation is improved. Date: Thu Jul 15 14:07:22 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.28 movitz/losp/muerte/primitive-functions.lisp:1.29 --- movitz/losp/muerte/primitive-functions.lisp:1.28 Thu Jul 15 04:18:49 2004 +++ movitz/losp/muerte/primitive-functions.lisp Thu Jul 15 14:07:22 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.28 2004/07/15 11:18:49 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.29 2004/07/15 21:07:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -420,10 +420,12 @@ (:movl :edi (:esp 4)) ; terminate list (:jmp :ebx))) ; return -(define-primitive-function malloc () - "Stupid allocator.. Number of bytes in EBX. Result in EAX." +(define-primitive-function malloc-pointer-words () + "Stupid allocator.. Number of words in EAX/fixnum. +Result in EAX, with tag :other." (with-inline-assembly (:returns :multiple-values) - (:locally (:movl (:edi (:edi-offset malloc-buffer)) :eax)) + (:movl :eax :ebx) + (:locally (:movl (:edi (:edi-offset nursery-space)) :eax)) (:testb #xff :al) (:jnz '(:sub-program (not-initialized) (:int 110) @@ -440,9 +442,52 @@ (:halt) (:jmp 'failed))) (:movl :edx (:eax 4)) ; new cons pointer - (:leal (:eax :ecx) :eax) + (:leal (:eax :ecx 6) :eax) (:ret))) +(define-primitive-function malloc-non-pointer-words () + "Stupid allocator.. Number of words in EAX/fixnum. +Result in EAX, with tag 6." + (with-inline-assembly (:returns :multiple-values) + (:movl :eax :ebx) + (:locally (:movl (:edi (:edi-offset nursery-space)) :eax)) + (:testb #xff :al) + (:jnz '(:sub-program (not-initialized) + (:int 110) + (:halt) + (:jmp 'not-initialized))) + (:addl 7 :ebx) + (:andb #xf8 :bl) + (:movl (:eax 4) :ecx) ; cons pointer to ECX + (:leal (:ebx :ecx) :edx) ; new roof to EDX + (:cmpl :edx (:eax)) ; end of buffer? + (:jl '(:sub-program (failed) + (:movl (:eax) :esi) + (:int 112) + (:halt) + (:jmp 'failed))) + (:movl :edx (:eax 4)) ; new cons pointer + (:leal (:eax :ecx 6) :eax) + (:ret))) + +(define-compiler-macro malloc-pointer-words (words) + `(with-inline-assembly (:returns :eax :type pointer) + (:compile-form (:result-mode :eax) ,words) + (:call-local-pf malloc-pointer-words))) + +(defun malloc-pointer-words (words) + (check-type words (integer 2 *)) + (malloc-pointer-words words)) + +(define-compiler-macro malloc-non-pointer-words (words) + `(with-inline-assembly (:returns :eax :type pointer) + (:compile-form (:result-mode :eax) ,words) + (:call-local-pf malloc-non-pointer-words))) + +(defun malloc-non-pointer-words (words) + (check-type words (integer 2 *)) + (malloc-non-pointer-words words)) + (define-primitive-function muerte::get-cons-pointer () "Return in EAX the next object location with space for EAX words, with tag 6. Preserve ECX." @@ -452,16 +497,8 @@ ;; is never comitted. `(with-inline-assembly (:returns :multiple-values) (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) - (:movl :eax :ebx) - (:call-global-constant malloc) + (:call-local-pf malloc-pointer-words) (:locally (:movl (:edi (:edi-offset scratch0)) :ecx)) - (:leal (:eax 6) :eax) - (:ret)) - #+ignore - `(with-inline-assembly (:returns :multiple-values) - (:locally (:movl (:edi (:edi-offset malloc-buffer)) :eax)) - (:movl (:eax 4) :ecx) ; cons pointer to ECX - (:leal (:eax :ecx 6) :eax) (:ret)))) (do-it))) @@ -471,36 +508,26 @@ (macrolet ((do-it () ;; Since get-cons-pointer is implemented as an (already committed) - ;; malloc, this is a NOP - `(with-inline-assembly (:returns :multiple-values) - (:ret)) - #+ignore + ;; malloc, this is a no-op. `(with-inline-assembly (:returns :multiple-values) - (:pushl :eax) - (:pushl :ebx) - (:movl :ecx :ebx) - (:call-global-constant malloc) - (:popl :ebx) - (:popl :eax) (:ret)))) (do-it))) (defun malloc-initialize (buffer-start buffer-size) - "BUFFER-START: the (fixnum) 4K address. BUFFER-SIZE: The size in 4K units." + "BUFFER-START is the location from which to allocate. +BUFFER-SIZE is the number of words in the buffer." (check-type buffer-start fixnum) (check-type buffer-size fixnum) (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :eax) buffer-start) - (:shll #.(cl:- 12 movitz::+movitz-fixnum-shift+) :eax) - (:locally (:movl :eax (:edi (:edi-offset malloc-buffer)))) + (:locally (:movl :eax (:edi (:edi-offset nursery-space)))) (:compile-form (:result-mode :ebx) buffer-size) - (:shll #.(cl:- 12 movitz::+movitz-fixnum-shift+) :ebx) (:movl :ebx (:eax)) ; roof pointern (:movl 16 (:eax 4)))) ; cons pointer (defun malloc-buffer-start () (with-inline-assembly (:returns :eax) - (:locally (:movl (:edi (:edi-offset malloc-buffer)) :eax)) + (:locally (:movl (:edi (:edi-offset nursery-space)) :eax)) (:testb 7 :al) (:jnz '(:sub-program () (:int 107))))) @@ -508,7 +535,7 @@ (defun malloc-cons-pointer () "Return current cons-pointer in 8-byte units since buffer-start." (with-inline-assembly (:returns :eax) - (:locally (:movl (:edi (:edi-offset malloc-buffer)) :eax)) + (:locally (:movl (:edi (:edi-offset nursery-space)) :eax)) (:movl (:eax 4) :eax) (:testb 7 :al) (:jnz '(:sub-program () @@ -524,7 +551,7 @@ "Allocate a cons cell. Call with car in eax and cdr in ebx." (with-inline-assembly (:returns :multiple-values) (:xchgl :eax :ecx) - (:locally (:movl (:edi (:edi-offset malloc-buffer)) :eax)) + (:locally (:movl (:edi (:edi-offset nursery-space)) :eax)) (:movl (:eax 4) :edx) (:addl 8 :edx) (:cmpl :edx (:eax)) @@ -570,14 +597,14 @@ (:ret) not-fixnum (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) ; Save value for later - (:call-global-constant malloc) + (:movl ,(* 2 movitz:+movitz-fixnum-factor+) :eax) + (:call-local-pf malloc-non-pointer-words) (:movl ,(dpb movitz:+movitz-fixnum-factor+ (byte 16 16) (movitz:tag :bignum 0)) - (:eax)) + (:eax ,movitz:+other-type-offset+)) (:locally (:movl (:edi (:edi-offset scratch0)) :ecx)) ; Restore value - (:movl :ecx (:eax 4)) - (:leal (:eax 6) :eax) + (:movl :ecx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) (:ret)))) (do-it)))

1 0