From ffjeld at common-lisp.net Tue Jun 1 13:38:35 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 01 Jun 2004 06:38:35 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv8756 Modified Files: integers.lisp Log Message: Added bignum support in evenp, and thus also oddp. Date: Tue Jun 1 06:38:35 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.12 movitz/losp/muerte/integers.lisp:1.13 --- movitz/losp/muerte/integers.lisp:1.12 Mon May 24 15:38:03 2004 +++ movitz/losp/muerte/integers.lisp Tue Jun 1 06:38:35 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.12 2004/05/24 22:38:03 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.13 2004/06/01 13:38:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -32,15 +32,28 @@ (typep x 'fixnum)) (defun evenp (x) - (with-inline-assembly (:returns :ebx) - (:compile-form (:result-mode :eax) x) - (:globally (:movl (:edi (:edi-offset t-symbol)) :ebx)) - (:testb #.(cl:1+ (cl:* 2 movitz::+movitz-fixnum-zmask+)) :al) - (:jz 'done) - (:movl :edi :ebx) - (:testb #.movitz::+movitz-fixnum-zmask+ :al) - (:jnz '(:sub-program (not-fixnum) (:int 107) (:jmp (:pc+ -4)))) - done)) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :ebx) + (:compile-form (:result-mode :eax) x) + (:movl :eax :ecx) + (:andl 7 :ecx) + (:globally (:movl (:edi (:edi-offset t-symbol)) :ebx)) + (:cmpl ,(movitz:tag :even-fixnum) :ecx) + (:je 'done) + (:movl :edi :ebx) + (:cmpl ,(movitz:tag :odd-fixnum) :ecx) + (:je 'done) + (:cmpl ,(movitz:tag :other) :ecx) + (:jnz '(:sub-program (not-integer) + (:int 107))) + (:cmpb ,(movitz:tag :bignum) (:eax ,movitz:+other-type-offset+)) + (:jne 'not-integer) + (:testb 1 (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:jnz 'done) + (:globally (:movl (:edi (:edi-offset t-symbol)) :ebx)) + done))) + (do-it))) (defun oddp (x) (not (evenp x))) @@ -64,6 +77,7 @@ (cons constant-term non-constant-operands)))))) `(+ (+%2op ,(first operands) ,(second operands)) ,@(cddr operands)))))) +#+ignore (defun +%2op (term1 term2) (check-type term1 fixnum) (check-type term2 fixnum) @@ -73,37 +87,36 @@ (:addl :ebx :eax) (:into))) -#+ignore -(define-compiler-macro +%2op (&whole form term1 term2) - (cond - ((and (movitz:movitz-constantp term1) ; first operand zero? - (zerop (movitz:movitz-eval term1))) - term2) ; (+ 0 x) => x - ((and (movitz:movitz-constantp term2) ; second operand zero? - (zerop (movitz:movitz-eval term2))) - term1) ; (+ x 0) => x - ((and (movitz:movitz-constantp term1) - (movitz:movitz-constantp term2)) - (+ (movitz:movitz-eval term1) - (movitz:movitz-eval term2))) ; compile-time constant folding. - ((movitz:movitz-constantp term1) - (let ((constant-term1 (movitz:movitz-eval term1))) - (check-type constant-term1 (signed-byte 30)) - `(with-inline-assembly (:returns :register :side-effects nil) ; inline - (:compile-form (:result-mode :register) ,term2) - (:addl ,(* movitz::+movitz-fixnum-factor+ constant-term1) (:result-register)) - (:into)))) - ((movitz:movitz-constantp term2) - (let ((constant-term2 (movitz:movitz-eval term2))) - (check-type constant-term2 (signed-byte 30)) - `(with-inline-assembly (:returns :register :side-effects nil) ; inline - (:compile-form (:result-mode :register) ,term1) - (:addl ,(* movitz::+movitz-fixnum-factor+ constant-term2) (:result-register)) - (:into)))) - (t `(with-inline-assembly (:returns :eax :side-effects nil) - (:compile-two-forms (:ebx :eax) ,term1 ,term2) - (:addl :ebx :eax) - (:into))))) +;;;(define-compiler-macro +%2op (&whole form term1 term2) +;;; (cond +;;; ((and (movitz:movitz-constantp term1) ; first operand zero? +;;; (zerop (movitz:movitz-eval term1))) +;;; term2) ; (+ 0 x) => x +;;; ((and (movitz:movitz-constantp term2) ; second operand zero? +;;; (zerop (movitz:movitz-eval term2))) +;;; term1) ; (+ x 0) => x +;;; ((and (movitz:movitz-constantp term1) +;;; (movitz:movitz-constantp term2)) +;;; (+ (movitz:movitz-eval term1) +;;; (movitz:movitz-eval term2))) ; compile-time constant folding. +;;; ((movitz:movitz-constantp term1) +;;; (let ((constant-term1 (movitz:movitz-eval term1))) +;;; (check-type constant-term1 (signed-byte 30)) +;;; `(with-inline-assembly (:returns :register :side-effects nil) ; inline +;;; (:compile-form (:result-mode :register) ,term2) +;;; (:addl ,(* movitz::+movitz-fixnum-factor+ constant-term1) (:result-register)) +;;; (:into)))) +;;; ((movitz:movitz-constantp term2) +;;; (let ((constant-term2 (movitz:movitz-eval term2))) +;;; (check-type constant-term2 (signed-byte 30)) +;;; `(with-inline-assembly (:returns :register :side-effects nil) ; inline +;;; (:compile-form (:result-mode :register) ,term1) +;;; (:addl ,(* movitz::+movitz-fixnum-factor+ constant-term2) (:result-register)) +;;; (:into)))) +;;; (t `(with-inline-assembly (:returns :eax :side-effects nil) +;;; (:compile-two-forms (:ebx :eax) ,term1 ,term2) +;;; (:addl :ebx :eax) +;;; (:into))))) (defun 1+ (number) (+ 1 number)) @@ -194,7 +207,7 @@ ((movitz:movitz-constantp subtrahend) (let ((constant-subtrahend (movitz:movitz-eval subtrahend))) (check-type constant-subtrahend (signed-byte 30)) - `(+%2op ,minuend ,(- constant-subtrahend)))) + `(+ ,minuend ,(- constant-subtrahend)))) (t `(with-inline-assembly (:returns :eax :side-effects nil) (:compile-two-forms (:eax :ebx) ,minuend ,subtrahend) (:subl :ebx :eax) From ffjeld at common-lisp.net Tue Jun 1 13:42:06 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 01 Jun 2004 06:42:06 -0700 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv10362 Modified Files: image.lisp Log Message: Added concept of "thread-atomical" code, which allows some small section of code to run atomically with respect to the same thread (i.e. should the thread be interrupted for whatever reason). "Atomically" is here used in the sense all-or-nothing. Such code-blocks can still be interrupted, but if so, it will be re-started from some declared starting-point. Date: Tue Jun 1 06:42:06 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.31 movitz/image.lisp:1.32 --- movitz/image.lisp:1.31 Mon May 24 12:05:59 2004 +++ movitz/image.lisp Tue Jun 1 06:42:06 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.31 2004/05/24 19:05:59 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.32 2004/06/01 13:42:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -450,11 +450,39 @@ (segment-descriptor-7 :binary-type segment-descriptor :initform (make-segment-descriptor)) + (atomically-status + :binary-type (define-bitfield atomically-status (lu32) + (((:enum :byte (2 3)) + :inactive 0 + :restart-primitive-function 1) ; data = slot-offset of pf. + ((:bits) :reset-status-p 7 + :eax 8 + :ebx 9 + :ecx 10 + :edx 11) + ((:numeric :data 16 16)))) + :initform '(:inactive)) + (atomically-registers + :binary-type lu32 + :initform 0) (bochs-flags :binary-type lu32 :initform 0) ) (:slot-align null-cons -1)) + +(defun atomically-status-simple-pf (pf-name reset-status-p &rest registers) + (bt:enum-value 'movitz::atomically-status + (list* :restart-primitive-function + (cons :reset-status-p + (if reset-status-p 1 0)) + (cons :data + (truncate (+ (tag :null) + (bt:slot-offset 'movitz-constant-block + (intern (symbol-name pf-name) + :movitz))) + 4)) + registers))) (defmethod movitz-object-offset ((obj movitz-constant-block)) 0) From ffjeld at common-lisp.net Tue Jun 1 13:42:14 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 01 Jun 2004 06:42:14 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv10384/losp Modified Files: los0-gc.lisp Log Message: Added concept of "thread-atomical" code, which allows some small section of code to run atomically with respect to the same thread (i.e. should the thread be interrupted for whatever reason). "Atomically" is here used in the sense all-or-nothing. Such code-blocks can still be interrupted, but if so, it will be re-started from some declared starting-point. Date: Tue Jun 1 06:42:14 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.12 movitz/losp/los0-gc.lisp:1.13 --- movitz/losp/los0-gc.lisp:1.12 Mon May 24 12:32:46 2004 +++ movitz/losp/los0-gc.lisp Tue Jun 1 06:42:14 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.12 2004/05/24 19:32:46 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.13 2004/06/01 13:42:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -56,21 +56,33 @@ (define-primitive-function los0-fast-cons () "Allocate a cons cell from nursery-space." - (with-inline-assembly (:returns :eax) - retry-cons - (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) - (:movl (:edx 2) :ecx) - (:cmpl #x3fff4 :ecx) - (:jge '(:sub-program () - (:int 113) - ;; This interrupt can be retried. - (:jmp 'retry-cons))) - (:movl :eax (:edx :ecx 2)) - (:movl :ebx (:edx :ecx 6)) - (:leal (:edx :ecx 3) :eax) - (:addl 8 :ecx) - (:movl :ecx (:edx 2)) - (:ret))) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + retry-cons + ;; Set up thread-atomical execution + (:locally (:movl ,(movitz::atomically-status-simple-pf 'fast-cons) + (:edi (:edi-offset atomically-status)))) + (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) + (:movl (:edx 2) :ecx) + (:cmpl #x3fff4 :ecx) + (:jge '(:sub-program (allocation-failed) + ;; Exit thread-atomical +;;; (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) +;;; (:edi (:edi-offset atomically-status)))) + (:int 113) + ;; This interrupt can be retried. + (:jmp 'retry-cons))) + (:movl :eax (:edx :ecx 2)) + (:movl :ebx (:edx :ecx 6)) + (:addl 8 :ecx) + (:movl :ecx (:edx 2)) ; Commit allocation + ;; Exit thread-atomical + (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) + (:edi (:edi-offset atomically-status)))) + (:leal (:edx :ecx -5) :eax) + (:ret)))) + (do-it))) (define-primitive-function los0-box-u32-ecx () "Make u32 in ECX into a fixnum or bignum." From ffjeld at common-lisp.net Tue Jun 1 13:42:19 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 01 Jun 2004 06:42:19 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10409/losp/muerte Modified Files: interrupt.lisp Log Message: Added concept of "thread-atomical" code, which allows some small section of code to run atomically with respect to the same thread (i.e. should the thread be interrupted for whatever reason). "Atomically" is here used in the sense all-or-nothing. Such code-blocks can still be interrupted, but if so, it will be re-started from some declared starting-point. Date: Tue Jun 1 06:42:19 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.7 movitz/losp/muerte/interrupt.lisp:1.8 --- movitz/losp/muerte/interrupt.lisp:1.7 Sun Apr 18 16:17:58 2004 +++ movitz/losp/muerte/interrupt.lisp Tue Jun 1 06:42:19 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.7 2004/04/18 23:17:58 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.8 2004/06/01 13:42:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -29,12 +29,12 @@ form (- 5 (position name '(nil :eflags :eip :error-code :exception :ebp nil - :ecx :eax :edx :ebx :esi :edi)))))) + :ecx :eax :edx :ebx :esi :edi :atomically-status)))))) (defun interrupt-frame-index (name) (- 5 (position name '(nil :eflags :eip :error-code :exception :ebp nil - :ecx :eax :edx :ebx :esi :edi)))) + :ecx :eax :edx :ebx :esi :edi :atomically-status)))) (define-compiler-macro interrupt-frame-ref (&whole form frame reg type &optional (offset 0) &environment env) @@ -48,100 +48,134 @@ (define-primitive-function default-interrupt-trampoline () "Default first-stage interrupt handler." - #.(cl:list* 'with-inline-assembly '(:returns :nothing) - (cl:loop :for i :from 0 :to movitz::+idt-size+ +;;; `(cl:list* 'with-inline-assembly '(:returns :nothing) +;;; (cl:loop :for i :from 0 :to movitz::+idt-size+ +;;; :append (cl:if (cl:member i '(8 10 11 12 13 14 17)) +;;; `(((5) :pushl ,i) +;;; ((5) :jmp 'ok)) +;;; `(((2) :pushl 0) ; replace Error Code +;;; ((2) :pushl ,i) +;;; ((1) :nop) +;;; ((5) :jmp 'ok))))) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :multiple-values) + ,@(loop :for i :from 0 :to movitz::+idt-size+ :append (cl:if (cl:member i '(8 10 11 12 13 14 17)) `(((5) :pushl ,i) ((5) :jmp 'ok)) `(((2) :pushl 0) ; replace Error Code ((2) :pushl ,i) ((1) :nop) - ((5) :jmp 'ok))))) - (with-inline-assembly (:returns :multiple-values) - ok - ;; Stack: - ;; 20: Interruptee EFLAGS (later EIP) - ;; 16: Interruptee CS (later EFLAGS) - ;; 12: Interruptee EIP - ;; 8: Error code - ;; 4: Exception number - ;; 0: EBP - (:pushl :ebp) - (:movl :esp :ebp) - (:pushl 0) ; 0 means default-interrupt-trampoline frame - (:pushl :ecx) ; -8 - (:pushl :eax) ; -12 - (:pushl :edx) ; -16 - (:pushl :ebx) ; -20 - (:pushl :esi) ; -24 - (:pushl :edi) ; -28 - - ;; rearrange stack for return - (:movl (:ebp 12) :eax) ; load return address - (:movl (:ebp 20) :ebx) ; load EFLAGS - (:movl :ebx (:ebp 16)) ; EFLAGS at next-to-bottom of stack - (:movl :eax (:ebp 20)) ; return address at bottom of stack - - (:xorl :eax :eax) ; Ensure safe value - (:xorl :edx :edx) ; Ensure safe value - - (:movl ':nil-value :edi) ; We want NIL! + ((5) :jmp 'ok)))) + ok + ;; Stack: + ;; 20: Interruptee EFLAGS (later EIP) + ;; 16: Interruptee CS (later EFLAGS) + ;; 12: Interruptee EIP + ;; 8: Error code + ;; 4: Exception number + ;; 0: EBP + (:pushl :ebp) + (:movl :esp :ebp) + (:pushl 0) ; 0 means default-interrupt-trampoline frame + (:pushl :ecx) ; -8 + (:pushl :eax) ; -12 + (:pushl :edx) ; -16 + (:pushl :ebx) ; -20 + (:pushl :esi) ; -24 + (:pushl :edi) ; -28 + (:movl ':nil-value :edi) ; We want NIL! + (:locally (:pushl (:edi (:edi-offset atomically-status)))) ; -32 + + (:locally (:movl 0 (:edi (:edi-offset atomically-status)))) + + ;; rearrange stack for return + (:movl (:ebp 12) :eax) ; load return address + (:movl (:ebp 20) :ebx) ; load EFLAGS + (:movl :ebx (:ebp 16)) ; EFLAGS at next-to-bottom of stack + (:movl :eax (:ebp 20)) ; return address at bottom of stack + + (:xorl :eax :eax) ; Ensure safe value + (:xorl :edx :edx) ; Ensure safe value + + (:pushl (:ebp 16)) ; EFLAGS + (:pushl :cs) ; push CS + (:call (:pc+ 0)) ; push EIP. + ;; Now add a few bytes to the on-stack EIP so the iret goes to + ;; *DEST* below. + ((4) :addl 5 (:esp)) ; 4 bytes + ((1) :iretd) ; 1 byte - (:pushl (:ebp 16)) ; EFLAGS - (:pushl :cs) ; push CS - (:call (:pc+ 0)) ; push EIP. - ;; Now add a few bytes to the on-stack EIP so the iret goes to - ;; *DEST* below. - ((4) :addl 5 (:esp)) ; 4 bytes - ((1) :iretd) ; 1 byte - - ;; *DEST* iret branches to here. - ;; we're now in the context of the interruptee. + ;; *DEST* iret branches to here. + ;; we're now in the context of the interruptee. - ;; Save/push thread-local values - (:locally (:movl (:edi (:edi-offset num-values)) :ecx)) - (:jecxz 'push-values-done) - (:leal (:edi #.(movitz::global-constant-offset 'values)) :eax) - push-values-loop - (:locally (:pushl (:eax))) - (:addl 4 :eax) - (:subl 1 :ecx) - (:jnz 'push-values-loop) - push-values-done - (:locally (:pushl (:edi (:edi-offset num-values)))) + ;; Save/push thread-local values + (:locally (:movl (:edi (:edi-offset num-values)) :ecx)) + (:jecxz 'push-values-done) + (:leal (:edi #.(movitz::global-constant-offset 'values)) :eax) + push-values-loop + (:locally (:pushl (:eax))) + (:addl 4 :eax) + (:subl 1 :ecx) + (:jnz 'push-values-loop) + push-values-done + (:locally (:pushl (:edi (:edi-offset num-values)))) + + ;; call handler + (:movl (:ebp 4) :ecx) ; interrupt number into ECX + (:locally (:movl (:edi (:edi-offset interrupt-handlers)) :eax)) + (:movl (:eax 2 (:ecx 4)) :esi) ; funobj at (aref EBX interrupt-handlers) into :esi + (:movl :ebp :ebx) ; pass interrupt-frame as arg1 + (:movl (:ebp 4) :ecx) ; pass interrupt number as arg 0. + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax) + (:call (:esi ,(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector%2op))) + + skip-interrupt-handler + ;; Restore thread-local values + (:popl :ecx) + (:locally (:movl :ecx (:edi (:edi-offset num-values)))) + (:jecxz 'pop-values-done) + pop-values-loop + ;; ((:fs-override) :popl (:edi #.(movitz::global-constant-offset 'values) (:ecx 4) -4)) + (:locally (:popl (:edi (:edi-offset values) (:ecx 4) -4))) + (:subl 1 :ecx) + (:jnz 'pop-values-loop) + pop-values-done + + (:movl (:ebp -32) :ecx) ; Check interruptee's atomically status + (:testb :cl :cl) + (:jnz 'restart-atomical-block) + + ;; Interrupted code was non-atomical, the normal case. + normal-return ; With atomically-status-to-restore in ECX + (:locally (:movl :ecx (:edi (:edi-offset atomically-status)))) + (:movl (:ebp -28) :edi) + (:movl (:ebp -24) :esi) + (:movl (:ebp -20) :ebx) + (:movl (:ebp -16) :edx) + (:movl (:ebp -12) :eax) + (:movl (:ebp -8) :ecx) + (:leave) + (:addl 12 :esp) + (:popfl) ; pop EFLAGS + (:ret) ; pop EIP - ;; call handler - (:movl (:ebp 4) :ecx) ; interrupt number into ECX - (:locally (:movl (:edi (:edi-offset interrupt-handlers)) :eax)) - (:movl (:eax 2 (:ecx 4)) :esi) ; funobj at (aref EBX interrupt-handlers) into :esi - (:movl :ebp :ebx) ; pass interrupt-frame as arg1 - (:movl (:ebp 4) :ecx) ; pass interrupt number as arg 0. - (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) :eax) - (:call (:esi #.(movitz::slot-offset 'movitz::movitz-funobj 'movitz::code-vector%2op))) - - skip-interrupt-handler - ;; Restore thread-local values - (:popl :ecx) - (:locally (:movl :ecx (:edi (:edi-offset num-values)))) - (:jecxz 'pop-values-done) - pop-values-loop - ;; ((:fs-override) :popl (:edi #.(movitz::global-constant-offset 'values) (:ecx 4) -4)) - (:locally (:popl (:edi (:edi-offset values) (:ecx 4) -4))) - (:subl 1 :ecx) - (:jnz 'pop-values-loop) - pop-values-done - - (:movl (:ebp -28) :edi) - (:movl (:ebp -24) :esi) - (:movl (:ebp -20) :ebx) - (:movl (:ebp -16) :edx) - (:movl (:ebp -12) :eax) - (:movl (:ebp -8) :ecx) - - (:leave) - (:addl 12 :esp) - (:popfl) ; pop EFLAGS - (:ret))) ; pop EIP + restart-atomical-block + (:cmpb ,(bt:enum-value 'movitz::atomically-status :restart-primitive-function) :cl) + (:jne 'not-simple-atomical-pf-restart) + (:cmpb 0 :ch) ; map of registers to restore + (:jnz 'not-simple-atomical-pf-restart) + (:sarl 16 :ecx) ; move atomically-status data into ECX + (:movl (:edi (:ecx 4) ,(- (movitz:tag :null))) + :ecx) ; This is the EIP to restart + (:movl :ecx (:ebp 20)) + (:jmp 'normal-return) + not-simple-atomical-pf-restart + ;; Don't know what to do. + (:int 90) + (:jmp 'not-simple-atomical-pf-restart) + ))))) (defvar *last-interrupt-frame* nil) From ffjeld at common-lisp.net Tue Jun 1 15:16:50 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 01 Jun 2004 08:16:50 -0700 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv23525 Modified Files: image.lisp Log Message: Fixed the atomically stuff to mostly working. Date: Tue Jun 1 08:16:49 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.32 movitz/image.lisp:1.33 --- movitz/image.lisp:1.32 Tue Jun 1 06:42:06 2004 +++ movitz/image.lisp Tue Jun 1 08:16:49 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.32 2004/06/01 13:42:06 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.33 2004/06/01 15:16:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -455,11 +455,11 @@ (((:enum :byte (2 3)) :inactive 0 :restart-primitive-function 1) ; data = slot-offset of pf. - ((:bits) :reset-status-p 7 - :eax 8 - :ebx 9 - :ecx 10 - :edx 11) + ((:bits) :reset-status-p 8 + :eax 9 + :ebx 10 + :ecx 11 + :edx 12) ((:numeric :data 16 16)))) :initform '(:inactive)) (atomically-registers @@ -477,11 +477,13 @@ (cons :reset-status-p (if reset-status-p 1 0)) (cons :data - (truncate (+ (tag :null) - (bt:slot-offset 'movitz-constant-block - (intern (symbol-name pf-name) - :movitz))) - 4)) + (if (not pf-name) + 0 + (truncate (+ (tag :null) + (bt:slot-offset 'movitz-constant-block + (intern (symbol-name pf-name) + :movitz))) + 4))) registers))) (defmethod movitz-object-offset ((obj movitz-constant-block)) 0) From ffjeld at common-lisp.net Tue Jun 1 15:16:54 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 01 Jun 2004 08:16:54 -0700 Subject: [movitz-cvs] CVS update: movitz/procfs-image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv23551 Modified Files: procfs-image.lisp Log Message: Fixed the atomically stuff to mostly working. Date: Tue Jun 1 08:16:54 2004 Author: ffjeld Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.5 movitz/procfs-image.lisp:1.6 --- movitz/procfs-image.lisp:1.5 Wed Apr 14 05:11:32 2004 +++ movitz/procfs-image.lisp Tue Jun 1 08:16:54 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.5 2004/04/14 12:11:32 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.6 2004/06/01 15:16:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -177,7 +177,7 @@ (loop with unknown-counter = 0 for stack-frame = (current-stack-frame) then (previous-stack-frame stack-frame) unless (zerop (mod stack-frame 4)) - do (format t "[#x~8,'0x]" stack-frame) + do (format t "[frame #x~8,'0x]" stack-frame) and do (loop-finish) do (let ((movitz-name (funobj-name (stack-frame-funobj stack-frame)))) (typecase movitz-name @@ -191,7 +191,8 @@ (edi (get-word (+ (* 4 (interrupt-frame-index :edi)) stack-frame))) (eip (get-word (+ (* 4 (interrupt-frame-index :eip)) stack-frame))) (exception (get-word (+ (* 4 (interrupt-frame-index :exception)) stack-frame)))) - (when r (format t " (ret #x~X {EAX: #x~X, ECX: #x~X, EDI: #x~X, EIP: #x~X, exception ~D})" + (when r (format t "#x~X (ret #x~X {EAX: #x~X, ECX: #x~X, EDI: #x~X, EIP: #x~X, exception ~D})" + stack-frame r eax ecx edi eip exception)))) (movitz-symbol (let ((name (movitz-print movitz-name))) From ffjeld at common-lisp.net Tue Jun 1 15:16:59 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 01 Jun 2004 08:16:59 -0700 Subject: [movitz-cvs] CVS update: movitz/stream-image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv23570 Modified Files: stream-image.lisp Log Message: Fixed the atomically stuff to mostly working. Date: Tue Jun 1 08:16:59 2004 Author: ffjeld Index: movitz/stream-image.lisp diff -u movitz/stream-image.lisp:1.5 movitz/stream-image.lisp:1.6 --- movitz/stream-image.lisp:1.5 Mon May 24 07:58:07 2004 +++ movitz/stream-image.lisp Tue Jun 1 08:16:59 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Aug 27 14:46:50 2001 ;;;; -;;;; $Id: stream-image.lisp,v 1.5 2004/05/24 14:58:07 ffjeld Exp $ +;;;; $Id: stream-image.lisp,v 1.6 2004/06/01 15:16:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -79,7 +79,7 @@ (read-binary 'movitz-symbol (image-stream image))) (:other (setf (image-stream-position image) - (+ 4 (extract-pointer word))) + (+ 0 (extract-pointer word))) (let* ((type-code (read-binary 'u8 (image-stream image))) (type-tag (enum-symbolic-value 'other-type-byte type-code))) (setf (image-stream-position image) From ffjeld at common-lisp.net Tue Jun 1 15:17:04 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 01 Jun 2004 08:17:04 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv23601 Modified Files: los0-gc.lisp Log Message: Fixed the atomically stuff to mostly working. Date: Tue Jun 1 08:17:04 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.13 movitz/losp/los0-gc.lisp:1.14 --- movitz/losp/los0-gc.lisp:1.13 Tue Jun 1 06:42:14 2004 +++ movitz/losp/los0-gc.lisp Tue Jun 1 08:17:04 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.13 2004/06/01 13:42:14 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.14 2004/06/01 15:17:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -61,7 +61,7 @@ `(with-inline-assembly (:returns :eax) retry-cons ;; Set up thread-atomical execution - (:locally (:movl ,(movitz::atomically-status-simple-pf 'fast-cons) + (:locally (:movl ,(movitz::atomically-status-simple-pf 'fast-cons t) (:edi (:edi-offset atomically-status)))) (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) (:movl (:edx 2) :ecx) From ffjeld at common-lisp.net Tue Jun 1 15:17:09 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 01 Jun 2004 08:17:09 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23639 Modified Files: interrupt.lisp Log Message: Fixed the atomically stuff to mostly working. Date: Tue Jun 1 08:17:08 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.8 movitz/losp/muerte/interrupt.lisp:1.9 --- movitz/losp/muerte/interrupt.lisp:1.8 Tue Jun 1 06:42:19 2004 +++ movitz/losp/muerte/interrupt.lisp Tue Jun 1 08:17:08 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.8 2004/06/01 13:42:19 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.9 2004/06/01 15:17:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -164,18 +164,26 @@ restart-atomical-block (:cmpb ,(bt:enum-value 'movitz::atomically-status :restart-primitive-function) :cl) (:jne 'not-simple-atomical-pf-restart) - (:cmpb 0 :ch) ; map of registers to restore + (:testl ,(bt:enum-value 'movitz::atomically-status '(:eax :ebx :ecx :edx)) + :ecx) ; map of registers to restore (:jnz 'not-simple-atomical-pf-restart) (:sarl 16 :ecx) ; move atomically-status data into ECX (:movl (:edi (:ecx 4) ,(- (movitz:tag :null))) :ecx) ; This is the EIP to restart (:movl :ecx (:ebp 20)) + (:movl (:ebp -32) :ecx) + (:testl ,(bt:enum-value 'movitz::atomically-status :reset-status-p) + :ecx) ; Should we reset status to zero? + (:jnz 'normal-return) + (:xorl :ecx :ecx) ; Do reset status to zero. (:jmp 'normal-return) not-simple-atomical-pf-restart ;; Don't know what to do. + (:halt) (:int 90) (:jmp 'not-simple-atomical-pf-restart) - ))))) + ))) + (do-it))) (defvar *last-interrupt-frame* nil) From ffjeld at common-lisp.net Wed Jun 2 10:39:48 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 02 Jun 2004 03:39:48 -0700 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv6221 Modified Files: image.lisp Log Message: Added another thread-atomically mechanism, allowing a jumper to be the restart-point. Date: Wed Jun 2 03:39:48 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.33 movitz/image.lisp:1.34 --- movitz/image.lisp:1.33 Tue Jun 1 08:16:49 2004 +++ movitz/image.lisp Wed Jun 2 03:39:48 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.33 2004/06/01 15:16:49 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.34 2004/06/02 10:39:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -452,9 +452,10 @@ :initform (make-segment-descriptor)) (atomically-status :binary-type (define-bitfield atomically-status (lu32) - (((:enum :byte (2 3)) + (((:enum :byte (3 2)) :inactive 0 - :restart-primitive-function 1) ; data = slot-offset of pf. + :restart-primitive-function 1 ; data = slot-offset of pf. + :restart-jumper 2) ; data = ESI-relative jumper number. ((:bits) :reset-status-p 8 :eax 9 :ebx 10 @@ -485,6 +486,16 @@ :movitz))) 4))) registers))) + +(defun atomically-status-jumper-fn (reset-status-p &rest registers) + (lambda (jumper) + (assert (= 0 (mod jumper 4))) + (bt:enum-value 'movitz::atomically-status + (list* :restart-jumper + (cons :reset-status-p + (if reset-status-p 1 0)) + (cons :data (truncate jumper 4)) + registers)))) (defmethod movitz-object-offset ((obj movitz-constant-block)) 0) From ffjeld at common-lisp.net Wed Jun 2 10:39:54 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 02 Jun 2004 03:39:54 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv6383 Modified Files: los0-gc.lisp Log Message: Added another thread-atomically mechanism, allowing a jumper to be the restart-point. Date: Wed Jun 2 03:39:54 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.14 movitz/losp/los0-gc.lisp:1.15 --- movitz/losp/los0-gc.lisp:1.14 Tue Jun 1 08:17:04 2004 +++ movitz/losp/los0-gc.lisp Wed Jun 2 03:39:54 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.14 2004/06/01 15:17:04 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.15 2004/06/02 10:39:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -68,8 +68,8 @@ (:cmpl #x3fff4 :ecx) (:jge '(:sub-program (allocation-failed) ;; Exit thread-atomical -;;; (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) -;;; (:edi (:edi-offset atomically-status)))) + (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) + (:edi (:edi-offset atomically-status)))) (:int 113) ;; This interrupt can be retried. (:jmp 'retry-cons))) @@ -95,62 +95,91 @@ (:ret) not-fixnum retry-cons + (:locally (:movl ,(movitz::atomically-status-simple-pf 'fast-cons t) + (:edi (:edi-offset atomically-status)))) (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) (:movl (:edx 2) :eax) (:cmpl #x3fff4 :eax) (:jge '(:sub-program () + (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) + (:edi (:edi-offset atomically-status)))) (:int 113) ; This interrupt can be retried. (:jmp 'retry-cons))) (:movl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0)) (:edx :eax 2)) (:movl :ecx (:edx :eax 6)) (:addl 8 :eax) - (:movl :eax (:edx 2)) + (:movl :eax (:edx 2)) ; Commit allocation + ;; Exit thread-atomical + (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) + (:edi (:edi-offset atomically-status)))) (:leal (:edx :eax) :eax) - (:ret) - (:int 107)))) + (:ret)))) (do-it))) (defun los0-malloc-clumps (clumps) - (check-type clumps (integer 0 4000)) - (with-inline-assembly (:returns :eax) - retry - (:compile-form (:result-mode :ebx) clumps) - (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) - (:movl (:edx 2) :ecx) - (:leal ((:ebx 2) :ecx) :eax) - (:cmpl #x3fff4 :eax) - (:jge '(:sub-program () - (:compile-form (:result-mode :ignore) - (stop-and-copy)) - (:jmp 'retry))) - (:movl :eax (:edx 2)) - (:movl #.(movitz:tag :infant-object) (:edx :ecx 6)) - (:leal (:edx :ecx 8) :eax) - (:xorl :ecx :ecx) - init-loop ; Now init eax number of clumps. - (:movl :edi (:eax (:ecx 2) -6)) - (:movl :edi (:eax (:ecx 2) -2)) - (:addl 4 :ecx) - (:cmpl :ebx :ecx) - (:jb 'init-loop))) + (check-type clumps (integer 0 16000)) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + retry + (:compile-form (:result-mode :ebx) clumps) + (:declare-label-set retry-jumper (retry)) + (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t) + 'retry-jumper) + (:edi (:edi-offset atomically-status)))) + (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) + (:movl (:edx 2) :ecx) + (:leal ((:ebx 2) :ecx) :eax) + (:cmpl #x3fff4 :eax) + (:jge '(:sub-program () + (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) + (:edi (:edi-offset atomically-status)))) + (:compile-form (:result-mode :ignore) + (stop-and-copy)) + (:jmp 'retry))) + (:movl :eax (:edx 2)) + (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) + (:edi (:edi-offset atomically-status)))) + (:movl #.(movitz:tag :infant-object) (:edx :ecx 6)) + (:leal (:edx :ecx 8) :eax) + (:xorl :ecx :ecx) + init-loop ; Now init eax number of clumps. + (:movl :edi (:eax (:ecx 2) -6)) + (:movl :edi (:eax (:ecx 2) -2)) + (:addl 4 :ecx) + (:cmpl :ebx :ecx) + (:jb 'init-loop)))) + (do-it))) (defun los0-malloc-data-clumps (clumps) (check-type clumps (integer 0 4000)) - (with-inline-assembly (:returns :eax) - retry - (:compile-form (:result-mode :ebx) clumps) - (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) - (:movl (:edx 2) :ecx) - (:leal ((:ebx 2) :ecx) :eax) - (:cmpl #x3fff4 :eax) - (:jge '(:sub-program () - (:compile-form (:result-mode :ignore) - (stop-and-copy)) - (:jmp 'retry))) - (:movl :eax (:edx 2)) - (:movl #.(movitz:tag :infant-object) (:edx :ecx 6)) - (:leal (:edx :ecx 8) :eax))) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + retry + (:compile-form (:result-mode :ebx) clumps) + (:declare-label-set retry-jumper (retry)) + (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t) + 'retry-jumper) + (:edi (:edi-offset atomically-status)))) + (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) + (:movl (:edx 2) :ecx) + (:leal ((:ebx 2) :ecx) :eax) + (:cmpl #x3fff4 :eax) + (:jge '(:sub-program () + (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) + (:edi (:edi-offset atomically-status)))) + (:compile-form (:result-mode :ignore) + (stop-and-copy)) + (:jmp 'retry))) + (:movl :eax (:edx 2)) + (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) + (:edi (:edi-offset atomically-status)))) + + (:movl #.(movitz:tag :infant-object) (:edx :ecx 6)) + (:leal (:edx :ecx 8) :eax)))) + (do-it))) (defun los0-handle-out-of-memory (exception interrupt-frame) (declare (ignore exception interrupt-frame)) From ffjeld at common-lisp.net Wed Jun 2 10:39:59 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 02 Jun 2004 03:39:59 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6433 Modified Files: interrupt.lisp Log Message: Added another thread-atomically mechanism, allowing a jumper to be the restart-point. Date: Wed Jun 2 03:39:59 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.9 movitz/losp/muerte/interrupt.lisp:1.10 --- movitz/losp/muerte/interrupt.lisp:1.9 Tue Jun 1 08:17:08 2004 +++ movitz/losp/muerte/interrupt.lisp Wed Jun 2 03:39:59 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.9 2004/06/01 15:17:08 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.10 2004/06/02 10:39:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -178,6 +178,23 @@ (:xorl :ecx :ecx) ; Do reset status to zero. (:jmp 'normal-return) not-simple-atomical-pf-restart + (:cmpb ,(bt:enum-value 'movitz::atomically-status :restart-jumper) :cl) + (:jne 'not-simple-restart-jumper) + (:testl ,(bt:enum-value 'movitz::atomically-status '(:eax :ebx :ecx :edx)) + :ecx) ; map of registers to restore + (:jnz 'not-simple-restart-jumper) + (:shrl 16 :ecx) ; move atomically-status data into ECX + (:movl (:ebp -24) :eax) ; This is the interruptee's ESI/funobj + (:movl (:eax (:ecx 4) ,(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0)) + :ecx) ; This is the EIP to restart + (:movl :ecx (:ebp 20)) + (:movl (:ebp -32) :ecx) + (:testl ,(bt:enum-value 'movitz::atomically-status :reset-status-p) + :ecx) ; Should we reset status to zero? + (:jnz 'normal-return) + (:xorl :ecx :ecx) ; Do reset status to zero. + (:jmp 'normal-return) + not-simple-restart-jumper ;; Don't know what to do. (:halt) (:int 90) From ffjeld at common-lisp.net Wed Jun 2 14:31:01 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 02 Jun 2004 07:31:01 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv21630 Modified Files: interrupt.lisp Log Message: Changed the signature of interrupt-frame-ref. Date: Wed Jun 2 07:31:01 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.10 movitz/losp/muerte/interrupt.lisp:1.11 --- movitz/losp/muerte/interrupt.lisp:1.10 Wed Jun 2 03:39:59 2004 +++ movitz/losp/muerte/interrupt.lisp Wed Jun 2 07:31:01 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.10 2004/06/02 10:39:59 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.11 2004/06/02 14:31:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -18,6 +18,8 @@ (provide :muerte/interrupt) +(defvar *last-interrupt-frame* nil) + (defmacro stack-word (offset) `(with-inline-assembly (:returns :eax) (:movl (:esp ,(* 4 offset)) :eax))) @@ -36,38 +38,31 @@ '(nil :eflags :eip :error-code :exception :ebp nil :ecx :eax :edx :ebx :esi :edi :atomically-status)))) -(define-compiler-macro interrupt-frame-ref (&whole form frame reg type &optional (offset 0) +(define-compiler-macro interrupt-frame-ref (&whole form reg type + &optional (offset 0) + (frame '*last-interrupt-frame*) &environment env) `(memref ,frame (+ (* 4 (interrupt-frame-index ,reg)) ,offset) 0 ,type)) -(defun interrupt-frame-ref (frame reg type &optional (offset 0)) - (interrupt-frame-ref frame reg type offset)) +(defun interrupt-frame-ref (reg type &optional (offset 0) (frame *last-interrupt-frame*)) + (interrupt-frame-ref reg type offset frame)) -(defun (setf interrupt-frame-ref) (x frame reg type) +(defun (setf interrupt-frame-ref) (x reg type &optional (frame *last-interrupt-frame*)) (setf (memref frame (* 4 (interrupt-frame-index reg)) 0 type) x)) (define-primitive-function default-interrupt-trampoline () "Default first-stage interrupt handler." -;;; `(cl:list* 'with-inline-assembly '(:returns :nothing) -;;; (cl:loop :for i :from 0 :to movitz::+idt-size+ -;;; :append (cl:if (cl:member i '(8 10 11 12 13 14 17)) -;;; `(((5) :pushl ,i) -;;; ((5) :jmp 'ok)) -;;; `(((2) :pushl 0) ; replace Error Code -;;; ((2) :pushl ,i) -;;; ((1) :nop) -;;; ((5) :jmp 'ok))))) (macrolet ((do-it () `(with-inline-assembly (:returns :multiple-values) - ,@(loop :for i :from 0 :to movitz::+idt-size+ - :append (cl:if (cl:member i '(8 10 11 12 13 14 17)) - `(((5) :pushl ,i) - ((5) :jmp 'ok)) - `(((2) :pushl 0) ; replace Error Code - ((2) :pushl ,i) - ((1) :nop) - ((5) :jmp 'ok)))) + ,@(loop for i from 0 to movitz::+idt-size+ + append (if (member i '(8 10 11 12 13 14 17)) + `(((5) :pushl ,i) + ((5) :jmp 'ok)) + `(((2) :pushl 0) ; replace Error Code + ((2) :pushl ,i) + ((1) :nop) + ((5) :jmp 'ok)))) ok ;; Stack: ;; 20: Interruptee EFLAGS (later EIP) @@ -202,8 +197,6 @@ ))) (do-it))) -(defvar *last-interrupt-frame* nil) - (defun interrupt-default-handler (number interrupt-frame) (declare (without-check-stack-limit)) (macrolet ((@ (fixnum-address &optional (type :lisp)) @@ -223,7 +216,7 @@ (6 (error "Illegal instruction at ~@Z." $eip)) (13 (error "General protection error. EIP=~@Z, error-code: #x~X, EAX: ~@Z, EBX: ~@Z, ECX: ~@Z" $eip - (interrupt-frame-ref interrupt-frame :error-code :unsigned-byte32) + (interrupt-frame-ref :error-code :unsigned-byte32 0 interrupt-frame) $eax $ebx $ecx)) ((61) ;; EAX failed type in EDX. May be restarted by returning with a new value in EAX. @@ -283,12 +276,12 @@ (error 'unbound-variable :name name)))) ((100);; 101 102 103 104 105) (let ((funobj (@ (+ interrupt-frame (interrupt-frame-index :esi)))) - (code (interrupt-frame-ref interrupt-frame :ecx :unsigned-byte8))) + (code (interrupt-frame-ref :ecx :unsigned-byte8 0 interrupt-frame))) (error 'wrong-argument-count :function funobj :argument-count (if (logbitp 7 code) - (ash (interrupt-frame-ref interrupt-frame - :ecx :unsigned-byte32) + (ash (interrupt-frame-ref :ecx :unsigned-byte32 + 0 interrupt-frame) -24) code)))) (108 From ffjeld at common-lisp.net Wed Jun 2 14:31:15 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 02 Jun 2004 07:31:15 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv22045 Modified Files: scavenge.lisp Log Message: Changed the signature of interrupt-frame-ref. Date: Wed Jun 2 07:31:15 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.7 movitz/losp/muerte/scavenge.lisp:1.8 --- movitz/losp/muerte/scavenge.lisp:1.7 Fri May 21 02:40:19 2004 +++ movitz/losp/muerte/scavenge.lisp Wed Jun 2 07:31:15 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.7 2004/05/21 09:40:19 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.8 2004/06/02 14:31:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -112,7 +112,7 @@ (+ frame (interrupt-frame-index :ecx))) (let* ((interrupt-frame frame) (interrupted-eip-loc - (interrupt-frame-ref interrupt-frame :eip :signed-byte30+2))) + (interrupt-frame-ref :eip :signed-byte30+2 0 interrupt-frame))) ;; 2. Pop to interrupted frame (setf nether-frame frame frame (stack-frame-uplink frame)) From ffjeld at common-lisp.net Wed Jun 2 14:31:20 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 02 Jun 2004 07:31:20 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv22163 Modified Files: debugger.lisp Log Message: Changed the signature of interrupt-frame-ref. Date: Wed Jun 2 07:31:20 2004 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.10 movitz/losp/x86-pc/debugger.lisp:1.11 --- movitz/losp/x86-pc/debugger.lisp:1.10 Thu Apr 15 12:57:10 2004 +++ movitz/losp/x86-pc/debugger.lisp Wed Jun 2 07:31:20 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.10 2004/04/15 19:57:10 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.11 2004/06/02 14:31:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -466,7 +466,7 @@ (typecase funobj (integer (let* ((interrupt-frame stack-frame) - (funobj (interrupt-frame-ref interrupt-frame :esi :lisp))) + (funobj (interrupt-frame-ref :esi :lisp 0 interrupt-frame))) (if (and conflate-interrupts conflate ;; When the interrupted function has a stack-frame, conflate it. (typep funobj 'function) @@ -476,9 +476,10 @@ (incf count) (print-leadin stack-frame count conflate-count) (setf conflate-count 0) - (let ((exception (interrupt-frame-ref interrupt-frame :exception - :unsigned-byte32)) - (eip (interrupt-frame-ref interrupt-frame :eip :unsigned-byte32))) + (let ((exception (interrupt-frame-ref :exception :unsigned-byte32 + 0 interrupt-frame)) + (eip (interrupt-frame-ref :eip :unsigned-byte32 + 0 interrupt-frame))) (typecase funobj (function (let ((delta (code-vector-offset (funobj-code-vector funobj) eip))) From ffjeld at common-lisp.net Wed Jun 2 20:34:04 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 02 Jun 2004 13:34:04 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2677 Modified Files: integers.lisp Log Message: Added some bignum support to +, i.e. two fixnums may now overflow to a bignum. Also changed - a bit. Date: Wed Jun 2 13:34:04 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.13 movitz/losp/muerte/integers.lisp:1.14 --- movitz/losp/muerte/integers.lisp:1.13 Tue Jun 1 06:38:35 2004 +++ movitz/losp/muerte/integers.lisp Wed Jun 2 13:34:04 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.13 2004/06/01 13:38:35 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.14 2004/06/02 20:34:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,6 +28,13 @@ (deftype positive-bignum () `(integer ,(1+ movitz:+movitz-most-positive-fixnum+) *)) +(defmacro number-double-dispatch ((x y) &rest clauses) + `(let ((x ,x) (y ,y)) + (cond ,@(loop for ((x-type y-type) . then-body) in clauses + collect `((and (typep x ',x-type) (typep y ',y-type)) + , at then-body)) + (t (error "Not numbers: ~S or ~S." x y))))) + (defun fixnump (x) (typep x 'fixnum)) @@ -134,16 +141,32 @@ (numargs-case (1 (x) x) (2 (x y) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) x) - (:compile-form (:result-mode :ebx) y) - (:movl :eax :ecx) - (:orl :ebx :ecx) - (:testb #.movitz::+movitz-fixnum-zmask+ :cl) - (:jnz '(:sub-program (not-integer) ; - (:int 107))) - (:addl :ebx :eax) - (:into))) + (macrolet + ((do-it () + `(number-double-dispatch (x y) + ((fixnum fixnum) + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) x) + (:compile-form (:result-mode :ebx) y) + (:addl :ebx :eax) + (:jo '(:sub-program (fix-fix-overflow) + (:movl :eax :ecx) + (:jns 'fix-fix-negative) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:call-global-constant box-u32-ecx) + (:jmp 'fix-fix-ok) + fix-fix-negative + (:negl :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:call-global-constant box-u32-ecx) + (:movl ,(dpb 1 (byte 16 16) + (movitz:tag :bignum #xff)) + (:eax ,movitz:+other-type-offset+)) + (:jmp 'fix-fix-ok) + )) + fix-fix-ok + ))))) + (do-it))) (3 (x y z) (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) x) @@ -153,7 +176,8 @@ (:orl :ebx :ecx) (:orl :edx :ecx) (:testb #.movitz::+movitz-fixnum-zmask+ :cl) - (:jnz 'not-integer) + (:jnz '(:sub-program (not-integer) + (:int 107))) (:addl :ebx :eax) (:into) (:addl :edx :eax) @@ -171,62 +195,34 @@ ;;; Subtraction -(define-compiler-macro - (&whole form &rest operands) +(define-compiler-macro - (&whole form &rest operands &environment env) (case (length operands) (0 0) - (1 `(-%2op 0 ,(first operands))) - (2 `(-%2op ,(first operands) ,(second operands))) - (t `(- (-%2op ,(first operands) ,(second operands)) - ,@(cddr operands))))) - - -(define-compiler-macro -%2op (&whole form minuend subtrahend) - (cond - ((and (movitz:movitz-constantp minuend) ; first operand zero? - (zerop (movitz:movitz-eval minuend))) - `(with-inline-assembly (:returns :register :side-effects nil) - (:compile-form (:result-mode :register) ,subtrahend) - (:negl (:result-register)) ; (- 0 x) => -x - (:into))) - ((and (movitz:movitz-constantp subtrahend) ; second operand zero? - (zerop (movitz:movitz-eval subtrahend))) - (movitz:movitz-eval minuend)) ; (- x 0) => x - ((and (movitz:movitz-constantp minuend) - (movitz:movitz-constantp subtrahend)) - (- (movitz:movitz-eval minuend) - (movitz:movitz-eval subtrahend))) ; compile-time constant folding. - ((movitz:movitz-constantp minuend) - (let ((constant-minuend (movitz:movitz-eval minuend))) - (check-type constant-minuend (signed-byte 30)) - `(with-inline-assembly (:returns :register :side-effects nil) ; inline - (:compile-form (:result-mode :register) ,subtrahend) - (:subl ,(* movitz::+movitz-fixnum-factor+ constant-minuend) (:result-register)) - ;;;;;;; NEED CHECKING HERE - (:into) - (:negl (:result-register))))) - ((movitz:movitz-constantp subtrahend) - (let ((constant-subtrahend (movitz:movitz-eval subtrahend))) - (check-type constant-subtrahend (signed-byte 30)) - `(+ ,minuend ,(- constant-subtrahend)))) - (t `(with-inline-assembly (:returns :eax :side-effects nil) - (:compile-two-forms (:eax :ebx) ,minuend ,subtrahend) - (:subl :ebx :eax) - (:into))))) - -(defun -%2op (minuend subtrahend) - (check-type minuend fixnum) - (check-type subtrahend fixnum) - (-%2op minuend subtrahend)) + (1 `(- 0 ,(first operands))) + (2 (let ((minuend (first operands)) + (subtrahend (second operands))) + (cond + ((movitz:movitz-constantp subtrahend env) + `(+ ,minuend ,(- (movitz:movitz-eval subtrahend env)))) + (t form)))) + (t `(- ,(first operands) (+ ,@(rest operands)))))) (defun - (minuend &rest subtrahends) (declare (dynamic-extent subtrahends)) - (if subtrahends - (reduce #'-%2op subtrahends :initial-value minuend) - (-%2op 0 minuend))) + (numargs-case + (2 (minuend subtrahend) + (check-type minuend fixnum) + (check-type subtrahend fixnum) + (with-inline-assembly (:returns :eax :side-effects nil) + (:compile-two-forms (:eax :ebx) minuend subtrahend) + (:subl :ebx :eax) + (:into))) + (t (minuend &rest subtrahends) + (declare (dynamic-extent subtrahends)) + (if subtrahends + (reduce #'- subtrahends :initial-value minuend) + (- 0 minuend))))) -;;;(defmacro decf (place &optional (delta-form 1)) -;;; `(setf ,place (- ,place ,delta-form))) - (define-modify-macro decf (&optional (delta-form 1)) -) ;;; Comparison @@ -775,13 +771,6 @@ (:idivl :ebx :eax :edx) (:shll #.movitz::+movitz-fixnum-shift+ :eax)))))) (t form))) - -(defmacro number-double-dispatch ((x y) &rest clauses) - `(let ((x ,x) (y ,y)) - (cond ,@(loop for ((x-type y-type) . then-body) in clauses - collect `((and (typep x ',x-type) (typep y ',y-type)) - , at then-body)) - (t (error "Not numbers: ~S or ~S." x y))))) (defun truncate (number &optional (divisor 1)) (numargs-case From ffjeld at common-lisp.net Wed Jun 2 23:20:46 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 02 Jun 2004 16:20:46 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv25469 Modified Files: integers.lisp Log Message: Improved bignum support in + and -. Added function copy-bignum. Date: Wed Jun 2 16:20:46 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.14 movitz/losp/muerte/integers.lisp:1.15 --- movitz/losp/muerte/integers.lisp:1.14 Wed Jun 2 13:34:04 2004 +++ movitz/losp/muerte/integers.lisp Wed Jun 2 16:20:46 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.14 2004/06/02 20:34:04 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.15 2004/06/02 23:20:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -132,7 +132,7 @@ `(+ ,number 1)) (defun 1- (number) - (+ -1 number)) + (- number 1)) (define-compiler-macro 1- (number) `(- ,number 1)) @@ -156,6 +156,7 @@ (:call-global-constant box-u32-ecx) (:jmp 'fix-fix-ok) fix-fix-negative + (:jz 'fix-double-negative) (:negl :ecx) (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) (:call-global-constant box-u32-ecx) @@ -163,25 +164,13 @@ (movitz:tag :bignum #xff)) (:eax ,movitz:+other-type-offset+)) (:jmp 'fix-fix-ok) - )) + fix-double-negative + (:compile-form (:result-mode :eax) + ,(* 2 movitz:+movitz-most-negative-fixnum+)) + (:jmp 'fix-fix-ok))) fix-fix-ok ))))) (do-it))) - (3 (x y z) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) x) - (:compile-form (:result-mode :ebx) y) - (:movl :eax :ecx) - (:compile-form (:result-mode :edx) z) - (:orl :ebx :ecx) - (:orl :edx :ecx) - (:testb #.movitz::+movitz-fixnum-zmask+ :cl) - (:jnz '(:sub-program (not-integer) - (:int 107))) - (:addl :ebx :eax) - (:into) - (:addl :edx :eax) - (:into))) (t (&rest terms) (declare (dynamic-extent terms)) (if (null terms) @@ -198,7 +187,10 @@ (define-compiler-macro - (&whole form &rest operands &environment env) (case (length operands) (0 0) - (1 `(- 0 ,(first operands))) + (1 (let ((x (first operands))) + (if (movitz:movitz-constantp x env) + (- (movitz:movitz-eval x env)) + form))) (2 (let ((minuend (first operands)) (subtrahend (second operands))) (cond @@ -210,13 +202,53 @@ (defun - (minuend &rest subtrahends) (declare (dynamic-extent subtrahends)) (numargs-case + (1 (x) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) x) + (:testb ,movitz:+movitz-fixnum-zmask+ :al) + (:jnz '(:sub-program (not-fixnum) + (:leal (:eax ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jnz '(:sub-program (not-a-number) + (:compile-form (:result-mode :ignore) + (error 'type-error :expected-type 'number :datum x)))) + (:movl (:eax ,movitz:+other-type-offset+) :ecx) + (:cmpb ,(movitz:tag :bignum) :cl) + (:jne 'not-a-number) + (:cmpl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0)) :ecx) + (:jne 'not-most-negative-fixnum) + (:cmpl ,(- most-negative-fixnum) + (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:jne 'not-most-negative-fixnum) + (:movl ,(ldb (byte 32 0) + (* most-negative-fixnum movitz::+movitz-fixnum-factor+)) + :eax) + (:jmp 'fix-ok) + not-most-negative-fixnum + (:compile-form (:result-mode :eax) + (copy-bignum x)) + (:notb (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::sign))) + (:jmp 'fix-ok))) + (:negl :eax) + (:jo '(:sub-program (fix-overflow) + (:compile-form (:result-mode :eax) + ,(1+ movitz:+movitz-most-positive-fixnum+)) + (:jmp 'fix-ok))) + fix-ok + ))) + (do-it))) (2 (minuend subtrahend) - (check-type minuend fixnum) - (check-type subtrahend fixnum) - (with-inline-assembly (:returns :eax :side-effects nil) - (:compile-two-forms (:eax :ebx) minuend subtrahend) - (:subl :ebx :eax) - (:into))) + (cond + ((eq 0 minuend) + (- subtrahend)) + (t (check-type minuend fixnum) + (check-type subtrahend fixnum) + (with-inline-assembly (:returns :eax :side-effects nil) + (:compile-two-forms (:eax :ebx) minuend subtrahend) + (:subl :ebx :eax) + (:into))))) (t (minuend &rest subtrahends) (declare (dynamic-extent subtrahends)) (if subtrahends @@ -1262,3 +1294,23 @@ (t (values (1- q) (+ r divisor)))))) (t (n &optional (divisor 1)) (floor n divisor)))) + +(defun copy-bignum (old) + (check-type old bignum) + (let* ((length (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) old) + (:movzxw (:eax #.(bt:slot-offset 'movitz::movitz-bignum + 'movitz::length)) + :ecx) + (:leal ((:ecx #.movitz:+movitz-fixnum-factor+) + #.movitz:+movitz-fixnum-factor+) + :eax))) + (new (malloc-data-clumps length))) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) new old) + (:compile-form (:result-mode :edx) length) + copy-bignum-loop + (:subl #.movitz:+movitz-fixnum-factor+ :edx) + (:movl (:ebx :edx #.movitz:+other-type-offset+) :ecx) + (:movl :ecx (:eax :edx #.movitz:+other-type-offset+)) + (:jnz 'copy-bignum-loop)))) From ffjeld at common-lisp.net Wed Jun 2 23:21:13 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 02 Jun 2004 16:21:13 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv25731 Modified Files: inspect.lisp Log Message: Added case for bignums in shallow-copy. Date: Wed Jun 2 16:21:13 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.9 movitz/losp/muerte/inspect.lisp:1.10 --- movitz/losp/muerte/inspect.lisp:1.9 Sat Apr 17 07:09:07 2004 +++ movitz/losp/muerte/inspect.lisp Wed Jun 2 16:21:13 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.9 2004/04/17 14:09:07 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.10 2004/06/02 23:21:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -175,6 +175,8 @@ (etypecase old (cons (cons (car old) (cdr old))) + (bignum + (copy-bignum old)) (std-instance (allocate-std-instance (std-instance-class old) (std-instance-slots old))) From ffjeld at common-lisp.net Wed Jun 2 23:48:15 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 02 Jun 2004 16:48:15 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2613 Modified Files: integers.lisp Log Message: Minor edit in *. Date: Wed Jun 2 16:48:15 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.15 movitz/losp/muerte/integers.lisp:1.16 --- movitz/losp/muerte/integers.lisp:1.15 Wed Jun 2 16:20:46 2004 +++ movitz/losp/muerte/integers.lisp Wed Jun 2 16:48:15 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.15 2004/06/02 23:20:46 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.16 2004/06/02 23:48:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -756,8 +756,8 @@ (:jne '(:sub-program (not-fixnum) (:int 107))) (:movl :ebx :ecx) - (:sarl #.movitz::+movitz-fixnum-shift+ :ebx) - (:imull :ebx :eax :edx) + (:sarl #.movitz::+movitz-fixnum-shift+ :ecx) + (:imull :ecx :eax :edx) (:into))) (t (&rest factors) (declare (dynamic-extent factors)) From ffjeld at common-lisp.net Wed Jun 2 23:48:46 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 02 Jun 2004 16:48:46 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2756 Modified Files: typep.lisp Log Message: Added bignum for typep. Date: Wed Jun 2 16:48:46 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.12 movitz/losp/muerte/typep.lisp:1.13 --- movitz/losp/muerte/typep.lisp:1.12 Mon May 24 07:59:01 2004 +++ movitz/losp/muerte/typep.lisp Wed Jun 2 16:48:45 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.12 2004/05/24 14:59:01 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.13 2004/06/02 23:48:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -174,6 +174,8 @@ `(with-inline-assembly (:returns :boolean-zf=1) (:compile-form (:result-mode :eax) ,object) (:testb ,movitz::+movitz-fixnum-zmask+ :al))) + ((bignum) + (make-other-typep :bignum)) ((integer number rational) `(with-inline-assembly-case () (do-case (t :boolean-zf=1 :labels (done)) @@ -510,8 +512,7 @@ (typep x 'fixnum)) (define-simple-typep (bignum bignump) (x) - (declare (ignore x)) - nil) + (typep x 'bignum)) (define-simple-typep (number numberp) (x) "Currently, only integer numbers are supported." From ffjeld at common-lisp.net Wed Jun 2 23:49:27 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 02 Jun 2004 16:49:27 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/cpu-id.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5396 Modified Files: cpu-id.lisp Log Message: Added decode-eflags. Date: Wed Jun 2 16:49:27 2004 Author: ffjeld Index: movitz/losp/muerte/cpu-id.lisp diff -u movitz/losp/muerte/cpu-id.lisp:1.4 movitz/losp/muerte/cpu-id.lisp:1.5 --- movitz/losp/muerte/cpu-id.lisp:1.4 Fri Apr 23 06:00:17 2004 +++ movitz/losp/muerte/cpu-id.lisp Wed Jun 2 16:49:27 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Apr 15 22:47:13 2002 ;;;; -;;;; $Id: cpu-id.lisp,v 1.4 2004/04/23 13:00:17 ffjeld Exp $ +;;;; $Id: cpu-id.lisp,v 1.5 2004/06/02 23:49:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -262,6 +262,16 @@ (defun eflags () (eflags)) + +(defconstant +eflags-map+ + '(:cf nil :pf nil :af nil :zf :sf + :tf :if :df :of :iopl0 :iopl1 :nt nil + :rf :vm :ac :vif :vip :id)) + +(defun decode-eflags (&optional (eflags (eflags))) + (loop for flag in +eflags-map+ as bit upfrom 0 + when (and flag (logbitp bit eflags)) + collect flag)) (define-compiler-macro (setf eflags) (value) `(with-inline-assembly (:returns :register) From ffjeld at common-lisp.net Wed Jun 2 23:50:34 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 02 Jun 2004 16:50:34 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/print.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7848 Modified Files: print.lisp Log Message: Removed hack from write-integer because there are bignums now. Date: Wed Jun 2 16:50:34 2004 Author: ffjeld Index: movitz/losp/muerte/print.lisp diff -u movitz/losp/muerte/print.lisp:1.9 movitz/losp/muerte/print.lisp:1.10 --- movitz/losp/muerte/print.lisp:1.9 Mon May 24 07:58:44 2004 +++ movitz/losp/muerte/print.lisp Wed Jun 2 16:50:34 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Sep 3 11:48:19 2001 ;;;; -;;;; $Id: print.lisp,v 1.9 2004/05/24 14:58:44 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.10 2004/06/02 23:50:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -113,25 +113,15 @@ (t (write-char #\# stream) (write-simple-integer base 10 stream) (write-char #\r stream)))) - (block minus-hack ; don't barf on most-negative-fixnum - (multiple-value-bind (sign-char print-value) - (cond - ((minusp x) - (if (not (eq x most-negative-fixnum)) - (values #\- (- x)) - (return-from minus-hack - (write-string (case base - (2 #.(cl:format cl:nil "~B" movitz::+movitz-most-negative-fixnum+)) - (8 #.(cl:format cl:nil "~O" movitz::+movitz-most-negative-fixnum+)) - (10 #.(cl:format cl:nil "~D" movitz::+movitz-most-negative-fixnum+)) - (16 #.(cl:format cl:nil "~X" movitz::+movitz-most-negative-fixnum+)) - (t (break "minus-hack!?"))) - stream)))) - (sign-always - (values #\+ x)) - (t (values nil x))) - (write-lowlevel-integer print-value stream base comma-char comma-interval - mincol padchar sign-char 0))) + (multiple-value-bind (sign-char print-value) + (cond + ((minusp x) + (values #\- (- x))) + (sign-always + (values #\+ x)) + (t (values nil x))) + (write-lowlevel-integer print-value stream base comma-char comma-interval + mincol padchar sign-char 0)) (when (and radix (= 10 base)) (write-char #\. stream)) nil) From ffjeld at common-lisp.net Wed Jun 2 23:52:26 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 02 Jun 2004 16:52:26 -0700 Subject: [movitz-cvs] CVS update: movitz/packages.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv9181 Modified Files: packages.lisp Log Message: Added symbol. Date: Wed Jun 2 16:52:26 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.23 movitz/packages.lisp:1.24 --- movitz/packages.lisp:1.23 Mon May 24 07:58:27 2004 +++ movitz/packages.lisp Wed Jun 2 16:52:26 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.23 2004/05/24 14:58:27 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.24 2004/06/02 23:52:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1271,6 +1271,7 @@ #:read-time-stamp-counter #:clear-time-stamp-counter #:eflags + #:decode-eflags #:load-idt #:segment-register #:control-register-lo12 From ffjeld at common-lisp.net Thu Jun 3 09:14:26 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 03 Jun 2004 02:14:26 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv15942 Modified Files: integers.lisp Log Message: Removed some dead code. Date: Thu Jun 3 02:14:26 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.16 movitz/losp/muerte/integers.lisp:1.17 --- movitz/losp/muerte/integers.lisp:1.16 Wed Jun 2 16:48:15 2004 +++ movitz/losp/muerte/integers.lisp Thu Jun 3 02:14:25 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.16 2004/06/02 23:48:15 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.17 2004/06/03 09:14:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -84,59 +84,6 @@ (cons constant-term non-constant-operands)))))) `(+ (+%2op ,(first operands) ,(second operands)) ,@(cddr operands)))))) -#+ignore -(defun +%2op (term1 term2) - (check-type term1 fixnum) - (check-type term2 fixnum) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) term1) - (:compile-form (:result-mode :ebx) term2) - (:addl :ebx :eax) - (:into))) - -;;;(define-compiler-macro +%2op (&whole form term1 term2) -;;; (cond -;;; ((and (movitz:movitz-constantp term1) ; first operand zero? -;;; (zerop (movitz:movitz-eval term1))) -;;; term2) ; (+ 0 x) => x -;;; ((and (movitz:movitz-constantp term2) ; second operand zero? -;;; (zerop (movitz:movitz-eval term2))) -;;; term1) ; (+ x 0) => x -;;; ((and (movitz:movitz-constantp term1) -;;; (movitz:movitz-constantp term2)) -;;; (+ (movitz:movitz-eval term1) -;;; (movitz:movitz-eval term2))) ; compile-time constant folding. -;;; ((movitz:movitz-constantp term1) -;;; (let ((constant-term1 (movitz:movitz-eval term1))) -;;; (check-type constant-term1 (signed-byte 30)) -;;; `(with-inline-assembly (:returns :register :side-effects nil) ; inline -;;; (:compile-form (:result-mode :register) ,term2) -;;; (:addl ,(* movitz::+movitz-fixnum-factor+ constant-term1) (:result-register)) -;;; (:into)))) -;;; ((movitz:movitz-constantp term2) -;;; (let ((constant-term2 (movitz:movitz-eval term2))) -;;; (check-type constant-term2 (signed-byte 30)) -;;; `(with-inline-assembly (:returns :register :side-effects nil) ; inline -;;; (:compile-form (:result-mode :register) ,term1) -;;; (:addl ,(* movitz::+movitz-fixnum-factor+ constant-term2) (:result-register)) -;;; (:into)))) -;;; (t `(with-inline-assembly (:returns :eax :side-effects nil) -;;; (:compile-two-forms (:ebx :eax) ,term1 ,term2) -;;; (:addl :ebx :eax) -;;; (:into))))) - -(defun 1+ (number) - (+ 1 number)) - -(define-compiler-macro 1+ (number) - `(+ ,number 1)) - -(defun 1- (number) - (- number 1)) - -(define-compiler-macro 1- (number) - `(- ,number 1)) - (defun + (&rest terms) (numargs-case (1 (x) x) @@ -177,8 +124,17 @@ 0 (reduce #'+ terms))))) -;;;(defmacro incf (place &optional (delta-form 1)) -;;; `(setf ,place (+ ,place ,delta-form))) +(defun 1+ (number) + (+ 1 number)) + +(define-compiler-macro 1+ (number) + `(+ ,number 1)) + +(defun 1- (number) + (- number 1)) + +(define-compiler-macro 1- (number) + `(- ,number 1)) (define-modify-macro incf (&optional (delta-form 1)) +) From ffjeld at common-lisp.net Fri Jun 4 13:32:17 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 04 Jun 2004 06:32:17 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12267 Modified Files: more-macros.lisp Log Message: Added a newline at end of file. Date: Fri Jun 4 06:32:17 2004 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.7 movitz/losp/muerte/more-macros.lisp:1.8 --- movitz/losp/muerte/more-macros.lisp:1.7 Mon Apr 19 15:38:33 2004 +++ movitz/losp/muerte/more-macros.lisp Fri Jun 4 06:32:16 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.7 2004/04/19 22:38:33 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.8 2004/06/04 13:32:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -309,4 +309,5 @@ `(,var (slot-value ,object-var ',slot)))) slot-entries) (let ((,object-var ,instance-form)) - , at declarations-and-forms)))) \ No newline at end of file + , at declarations-and-forms)))) + From ffjeld at common-lisp.net Fri Jun 4 13:33:16 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 04 Jun 2004 06:33:16 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12510 Modified Files: integers.lisp Log Message: Slightly improved + for bignums. Date: Fri Jun 4 06:33:16 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.17 movitz/losp/muerte/integers.lisp:1.18 --- movitz/losp/muerte/integers.lisp:1.17 Thu Jun 3 02:14:25 2004 +++ movitz/losp/muerte/integers.lisp Fri Jun 4 06:33:16 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.17 2004/06/03 09:14:25 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.18 2004/06/04 13:33:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -115,8 +115,25 @@ (:compile-form (:result-mode :eax) ,(* 2 movitz:+movitz-most-negative-fixnum+)) (:jmp 'fix-fix-ok))) - fix-fix-ok - ))))) + fix-fix-ok)) + ((positive-fixnum positive-bignum) + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) y) + (:jecxz 'pfix-pbig-done) + (:movzxw (:eax #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) + (:cmpl 1 :ecx) + (:jne 'not-size1) + (:compile-form (:result-mode :ecx) x) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:addl (:eax #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx) + (:jc '(:sub-program () + (:break))) + (:call-global-constant box-u32-ecx) + (:jmp 'pfix-pbig-done) + not-size1 + (:break) + pfix-pbig-done)) + ))) (do-it))) (t (&rest terms) (declare (dynamic-extent terms)) @@ -128,13 +145,13 @@ (+ 1 number)) (define-compiler-macro 1+ (number) - `(+ ,number 1)) + `(+ 1 ,number)) (defun 1- (number) - (- number 1)) + (+ -1 number)) (define-compiler-macro 1- (number) - `(- ,number 1)) + `(+ -1 ,number)) (define-modify-macro incf (&optional (delta-form 1)) +) From ffjeld at common-lisp.net Fri Jun 4 13:33:50 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 04 Jun 2004 06:33:50 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12638 Modified Files: interrupt.lisp Log Message: Improved restarting atomically blocks. Date: Fri Jun 4 06:33:50 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.11 movitz/losp/muerte/interrupt.lisp:1.12 --- movitz/losp/muerte/interrupt.lisp:1.11 Wed Jun 2 07:31:01 2004 +++ movitz/losp/muerte/interrupt.lisp Fri Jun 4 06:33:50 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.11 2004/06/02 14:31:01 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.12 2004/06/04 13:33:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -82,6 +82,7 @@ (:pushl :edi) ; -28 (:movl ':nil-value :edi) ; We want NIL! (:locally (:pushl (:edi (:edi-offset atomically-status)))) ; -32 + (:locally (:pushl (:edi (:edi-offset atomically-esp)))) ; -36 (:locally (:movl 0 (:edi (:edi-offset atomically-status)))) @@ -145,12 +146,18 @@ ;; Interrupted code was non-atomical, the normal case. normal-return ; With atomically-status-to-restore in ECX (:locally (:movl :ecx (:edi (:edi-offset atomically-status)))) + (:movl (:ebp -36) :ecx) ; Load interruptee's atomically-esp.. + (:locally (:movl :ecx (:edi (:edi-offset atomically-esp)))) ; ..and restore it. (:movl (:ebp -28) :edi) (:movl (:ebp -24) :esi) (:movl (:ebp -20) :ebx) (:movl (:ebp -16) :edx) (:movl (:ebp -12) :eax) (:movl (:ebp -8) :ecx) + ;; Make stack safe before we exit interrupt-frame.. + (:movl :edi (:ebp 4)) + (:movl :edi (:ebp 8)) + (:movl :edi (:ebp 12)) (:leave) (:addl 12 :esp) (:popfl) ; pop EFLAGS @@ -175,20 +182,42 @@ not-simple-atomical-pf-restart (:cmpb ,(bt:enum-value 'movitz::atomically-status :restart-jumper) :cl) (:jne 'not-simple-restart-jumper) - (:testl ,(bt:enum-value 'movitz::atomically-status '(:eax :ebx :ecx :edx)) + (:testl ,(bt:enum-value 'movitz::atomically-status :esp) :ecx) ; map of registers to restore - (:jnz 'not-simple-restart-jumper) - (:shrl 16 :ecx) ; move atomically-status data into ECX - (:movl (:ebp -24) :eax) ; This is the interruptee's ESI/funobj - (:movl (:eax (:ecx 4) ,(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0)) - :ecx) ; This is the EIP to restart - (:movl :ecx (:ebp 20)) + (:jnz 'atomically-esp-ok) + ;; Generate the correct ESP for interruptee's atomically-esp + (:leal (:ebp 24) :ecx) + (:movl :ecx (:ebp -36)) + atomically-esp-ok (:movl (:ebp -32) :ecx) (:testl ,(bt:enum-value 'movitz::atomically-status :reset-status-p) :ecx) ; Should we reset status to zero? - (:jnz 'normal-return) + (:jnz 'atomically-jumper-return) (:xorl :ecx :ecx) ; Do reset status to zero. - (:jmp 'normal-return) + + atomically-jumper-return + (:locally (:movl :ecx (:edi (:edi-offset atomically-status)))) + (:movl (:ebp -36) :ecx) ; Load interruptee's atomically-esp.. + (:locally (:movl :ecx (:edi (:edi-offset atomically-esp)))) ; ..and restore it. + (:movl (:ebp -28) :edi) + (:movl (:ebp -24) :esi) + (:movl (:ebp -16) :edx) + (:movl (:ebp -12) :eax) + (:movl (:ebp -8) :ecx) + + (:movl (:ebp -32) :ebx) ; atomically-status.. + (:shrl ,(- 16 movitz:+movitz-fixnum-shift+) :ebx) + + ;; Make stack safe before we exit interrupt-frame.. + (:movl :edi (:ebp 4)) + (:movl :edi (:ebp 8)) + (:movl :edi (:ebp 12)) + (:movl :edi (:ebp 16)) + (:movl :edi (:ebp 20)) + (:movl (:ebp 0) :ebp) ; pop stack-frame + (:locally (:movl (:edi (:edi-offset atomically-esp)) :esp)) ; restore ESP + (:jmp (:esi :ebx ,(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0))) + not-simple-restart-jumper ;; Don't know what to do. (:halt) From ffjeld at common-lisp.net Fri Jun 4 13:35:25 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 04 Jun 2004 06:35:25 -0700 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv14042 Modified Files: image.lisp Log Message: Improving atomically stuff. Date: Fri Jun 4 06:35:25 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.34 movitz/image.lisp:1.35 --- movitz/image.lisp:1.34 Wed Jun 2 03:39:48 2004 +++ movitz/image.lisp Fri Jun 4 06:35:25 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.34 2004/06/02 10:39:48 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.35 2004/06/04 13:35:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -457,13 +457,11 @@ :restart-primitive-function 1 ; data = slot-offset of pf. :restart-jumper 2) ; data = ESI-relative jumper number. ((:bits) :reset-status-p 8 - :eax 9 - :ebx 10 - :ecx 11 - :edx 12) + :esp 9 + :ebp 10) ((:numeric :data 16 16)))) :initform '(:inactive)) - (atomically-registers + (atomically-esp :binary-type lu32 :initform 0) (bochs-flags From ffjeld at common-lisp.net Fri Jun 4 13:35:31 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 04 Jun 2004 06:35:31 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv14164 Modified Files: los0-gc.lisp Log Message: Improving atomically stuff. Date: Fri Jun 4 06:35:31 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.15 movitz/losp/los0-gc.lisp:1.16 --- movitz/losp/los0-gc.lisp:1.15 Wed Jun 2 03:39:54 2004 +++ movitz/losp/los0-gc.lisp Fri Jun 4 06:35:31 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.15 2004/06/02 10:39:54 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.16 2004/06/04 13:35:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -54,6 +54,13 @@ (defun space-cons-pointer () (aref (%run-time-context-slot 'nursery-space) 0)) +(define-primitive-function los0-cons-pointer () + "" + (with-inline-assembly (:returns :multiple-values) + (:locally (:movl (:edi (:edi-offset nursery-space)) :eax)) + (:movl (:edx 2) :ecx))) + + (define-primitive-function los0-fast-cons () "Allocate a cons cell from nursery-space." (macrolet @@ -84,6 +91,7 @@ (:ret)))) (do-it))) + (define-primitive-function los0-box-u32-ecx () "Make u32 in ECX into a fixnum or bignum." (macrolet @@ -95,7 +103,7 @@ (:ret) not-fixnum retry-cons - (:locally (:movl ,(movitz::atomically-status-simple-pf 'fast-cons t) + (:locally (:movl ,(movitz::atomically-status-simple-pf 'box-u32-ecx t) (:edi (:edi-offset atomically-status)))) (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) (:movl (:edx 2) :eax) @@ -125,7 +133,7 @@ retry (:compile-form (:result-mode :ebx) clumps) (:declare-label-set retry-jumper (retry)) - (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t) + (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp) 'retry-jumper) (:edi (:edi-offset atomically-status)))) (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) @@ -133,11 +141,7 @@ (:leal ((:ebx 2) :ecx) :eax) (:cmpl #x3fff4 :eax) (:jge '(:sub-program () - (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) - (:edi (:edi-offset atomically-status)))) - (:compile-form (:result-mode :ignore) - (stop-and-copy)) - (:jmp 'retry))) + (:int 113))) (:movl :eax (:edx 2)) (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) (:edi (:edi-offset atomically-status)))) @@ -168,11 +172,7 @@ (:leal ((:ebx 2) :ecx) :eax) (:cmpl #x3fff4 :eax) (:jge '(:sub-program () - (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) - (:edi (:edi-offset atomically-status)))) - (:compile-form (:result-mode :ignore) - (stop-and-copy)) - (:jmp 'retry))) + (:int 113))) (:movl :eax (:edx 2)) (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) (:edi (:edi-offset atomically-status)))) @@ -180,11 +180,6 @@ (:movl #.(movitz:tag :infant-object) (:edx :ecx 6)) (:leal (:edx :ecx 8) :eax)))) (do-it))) - -(defun los0-handle-out-of-memory (exception interrupt-frame) - (declare (ignore exception interrupt-frame)) - (format t "~&;; Handling out-of-memory exception..") - (stop-and-copy)) (defun install-los0-consing () (setf (%run-time-context-slot 'nursery-space) From ffjeld at common-lisp.net Sun Jun 6 01:53:49 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 05 Jun 2004 18:53:49 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1342 Modified Files: integers.lisp Log Message: Improved truncate a good bit. Date: Sat Jun 5 18:53:48 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.18 movitz/losp/muerte/integers.lisp:1.19 --- movitz/losp/muerte/integers.lisp:1.18 Fri Jun 4 06:33:16 2004 +++ movitz/losp/muerte/integers.lisp Sat Jun 5 18:53:48 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.18 2004/06/04 13:33:16 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.19 2004/06/06 01:53:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -116,22 +116,65 @@ ,(* 2 movitz:+movitz-most-negative-fixnum+)) (:jmp 'fix-fix-ok))) fix-fix-ok)) + ((positive-bignum positive-fixnum) + (break "Hello?") + (+ y x)) ((positive-fixnum positive-bignum) (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) x) + (:testl :eax :eax) + (:jz 'pfix-pbig-done) (:compile-form (:result-mode :eax) y) - (:jecxz 'pfix-pbig-done) - (:movzxw (:eax #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) + (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) (:cmpl 1 :ecx) (:jne 'not-size1) (:compile-form (:result-mode :ecx) x) (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) - (:addl (:eax #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx) + (:addl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx) (:jc '(:sub-program () (:break))) (:call-global-constant box-u32-ecx) (:jmp 'pfix-pbig-done) not-size1 - (:break) + (:declare-label-set retry-jumper (not-size1)) + (:locally (:movl :esp (:edi (:edi-offset atomically-esp)))) + (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp) + 'retry-jumper) + (:edi (:edi-offset atomically-status)))) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,(* 2 movitz:+movitz-fixnum-factor+)) + :eax) ; Number of words + (:call-global-constant get-cons-pointer) + (:load-lexical (:lexical-binding y) :ebx) ; bignum + (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) + (:leal ((:ecx #.movitz:+movitz-fixnum-factor+) + #.movitz:+movitz-fixnum-factor+) + :edx) + (:movl 0 (:eax :edx ,movitz:+other-type-offset+)) ; MSB + copy-bignum-loop + (:subl ,movitz:+movitz-fixnum-factor+ :edx) + (:movl (:ebx :edx ,movitz:+other-type-offset+) :ecx) + (:movl :ecx (:eax :edx ,movitz:+other-type-offset+)) + (:jnz 'copy-bignum-loop) + + (:load-lexical (:lexical-binding x) :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:xorl :ebx :ebx) + (:addl :ecx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:jnc 'add-bignum-done) + add-bignum-loop + (:addl 4 :ebx) + (:addl 1 (:eax :ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:jc 'add-bignum-loop) + add-bignum-done + (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) #+ignore ,movitz:+movitz-fixnum-factor+) + :ebx) +;;; (:cmpl 0 (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0) + + (:call-global-constant cons-commit) + (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) + (:edi (:edi-offset atomically-status)))) + pfix-pbig-done)) ))) (do-it))) @@ -797,88 +840,100 @@ (:movb 2 :cl) ; return values: qutient, remainder. (:stc))) ((positive-bignum positive-fixnum) - (let (r n) - (with-inline-assembly (:returns :multiple-values) - (:compile-form (:result-mode :ebx) number) - (:movzxw (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) - (:cmpl 1 :ecx) - (:jne 'not-size1) - (:compile-form (:result-mode :ecx) divisor) - (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) - (:std) - (:movl (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :eax) - (:xorl :edx :edx) - (:divl :ecx :eax :edx) - (:movl :eax :ecx) - (:shll #.movitz:+movitz-fixnum-shift+ :edx) - (:movl :edi :eax) - (:cld) - (:pushl :edx) - (:call-global-constant box-u32-ecx) - (:popl :ebx) - (:jmp 'done) - not-size1 - (:cmpl 2 :ecx) - (:jne 'not-size2) - (:compile-form (:result-mode :ecx) divisor) - (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) - (:std) - (:movl (:ebx #.(cl:+ 4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) - :edx) - (:cmpl :ecx :edx) - (:jae 'not-size2) - (:movl (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :eax) - (:divl :ecx :eax :edx) - (:movl :eax :ecx) - (:shll #.movitz:+movitz-fixnum-shift+ :edx) - (:movl :edi :eax) - (:cld) - (:pushl :edx) - (:call-global-constant box-u32-ecx) - (:popl :ebx) - (:jmp 'done) - not-size2 - (:cmpl :ecx (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0) - -4 (:ecx 4))) - (:jc 'shrink-not-size2) - not-shrink - (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) :eax) - (:compile-form (:result-mode :eax) - (malloc-words (with-inline-assembly (:returns :eax)))) - (:store-lexical (:lexical-binding r) :eax :type t) - (:compile-form (:result-mode :ebx) number) - (:movl (:ebx #.movitz:+other-type-offset+) :ecx) - (:movl :ecx (:eax #.movitz:+other-type-offset+)) - (:shrl 16 :ecx) + (macrolet + ((do-it () + `(let (r n) + (with-inline-assembly (:returns :multiple-values) + (:compile-form (:result-mode :ebx) number) + (:cmpw 1 (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:jne 'not-size1) + (:compile-form (:result-mode :ecx) divisor) + (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) + (:std) + (:movl (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :eax) + (:xorl :edx :edx) + (:divl :ecx :eax :edx) + (:movl :eax :ecx) + (:shll #.movitz:+movitz-fixnum-shift+ :edx) + (:movl :edi :eax) + (:cld) + (:pushl :edx) + (:call-global-constant box-u32-ecx) + (:popl :ebx) + (:jmp 'done) + not-size1 + (:compile-form (:result-mode :ebx) number) + (:movzxw (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) + :ecx) + + (:declare-label-set retry-jumper (not-size1)) + (:locally (:movl :esp (:edi (:edi-offset atomically-esp)))) + (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp) + 'retry-jumper) + (:edi (:edi-offset atomically-status)))) + + (:leal ((:ecx #.movitz:+movitz-fixnum-factor+) #.movitz:+movitz-fixnum-factor+) + :eax) ; Number of words + (:call-global-constant get-cons-pointer) ; New bignum into EAX + + + (:store-lexical (:lexical-binding r) :eax :type bignum) + (:compile-form (:result-mode :ebx) number) + (:movl (:ebx #.movitz:+other-type-offset+) :ecx) + (:movl :ecx (:eax #.movitz:+other-type-offset+)) + (:shrl 16 :ecx) - (:xorl :edx :edx) ; edx=hi-digit=0 + (:xorl :edx :edx) ; edx=hi-digit=0 ; eax=lo-digit=msd(number) - (:std) - (:compile-form (:result-mode :esi) divisor) - (:shrl #.movitz:+movitz-fixnum-shift+ :esi) - - divide-loop - (:load-lexical (:lexical-binding number) :ebx) - (:movl (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0) - -4 (:ecx 4)) - :eax) - (:divl :esi :eax :edx) - (:load-lexical (:lexical-binding r) :ebx) - (:movl :eax (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0) - -4 (:ecx 4))) - (:subl 1 :ecx) - (:jnz 'divide-loop) - (:movl :ebx :eax) - (:leal ((:edx #.movitz:+movitz-fixnum-factor+)) :ebx) - (:movl :edi :edx) - (:movl (:ebp -4) :esi) - (:cld) - (:jmp 'done) - shrink-not-size2 - (:int 107) - done - (:movl 2 :ecx) - (:stc)))) + (:std) + (:compile-form (:result-mode :esi) divisor) + (:shrl #.movitz:+movitz-fixnum-shift+ :esi) + + divide-loop + (:load-lexical (:lexical-binding number) :ebx) + (:movl (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0) + -4 (:ecx 4)) + :eax) + (:divl :esi :eax :edx) + (:load-lexical (:lexical-binding r) :ebx) + (:movl :eax (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0) + -4 (:ecx 4))) + (:subl 1 :ecx) + (:jnz 'divide-loop) + (:movl :edi :eax) ; safe value + (:leal ((:edx ,movitz:+movitz-fixnum-factor+)) :edx) + (:movl (:ebp -4) :esi) + (:cld) + (:movl :ebx :eax) + (:movl :edx :ebx) + + (:movzxw (:eax #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) + :ecx) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) #.movitz:+movitz-fixnum-factor+) + :ecx) + (:cmpl 0 (:eax :ecx ,(+ -8 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))) + (:jne 'no-more-shrinkage) + + (:subw 1 (:eax #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:subl ,movitz:+movitz-fixnum-factor+ :ecx) + (:cmpl ,(* 2 movitz:+movitz-fixnum-factor+) :ecx) + (:jne 'no-more-shrinkage) + (:cmpl ,movitz:+movitz-most-positive-fixnum+ + (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:jnc 'no-more-shrinkage) + (:movl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) + :ecx) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax) + (:jmp 'fixnum-result) ; don't commit the bignum + no-more-shrinkage + (:call-global-constant cons-commit) + fixnum-result + (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) + (:edi (:edi-offset atomically-status)))) + done + (:movl 2 :ecx) + (:stc))))) + (do-it))) )))) (defun round (number &optional (divisor 1)) @@ -1268,17 +1323,22 @@ (t (n &optional (divisor 1)) (floor n divisor)))) +(define-compiler-macro %bignum-bigits (x) + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) ,x) + (:movzxw (:eax #.(bt:slot-offset 'movitz::movitz-bignum + 'movitz::length)) + :ecx) + (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) + :eax))) + +(defun %bignum-bigits (x) + (%bignum-bigits x)) + (defun copy-bignum (old) (check-type old bignum) - (let* ((length (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) old) - (:movzxw (:eax #.(bt:slot-offset 'movitz::movitz-bignum - 'movitz::length)) - :ecx) - (:leal ((:ecx #.movitz:+movitz-fixnum-factor+) - #.movitz:+movitz-fixnum-factor+) - :eax))) - (new (malloc-data-clumps length))) + (let* ((length (1+ (%bignum-bigits old))) + (new (malloc-data-words length))) (with-inline-assembly (:returns :eax) (:compile-two-forms (:eax :ebx) new old) (:compile-form (:result-mode :edx) length) @@ -1287,3 +1347,10 @@ (:movl (:ebx :edx #.movitz:+other-type-offset+) :ecx) (:movl :ecx (:eax :edx #.movitz:+other-type-offset+)) (:jnz 'copy-bignum-loop)))) + +(defun print-bignum (x) + (check-type x bignum) + (loop for i from 0 to (%bignum-bigits x) + do (format t "~8,'0X " (memref x -6 i :unsigned-byte32))) + (terpri) + (values)) \ No newline at end of file From ffjeld at common-lisp.net Sun Jun 6 02:10:55 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 05 Jun 2004 19:10:55 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10187 Modified Files: interrupt.lisp Log Message: More cruft for restarting atomically blocks. I really need to document this stuff properly before I forget the details. Date: Sat Jun 5 19:10:55 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.12 movitz/losp/muerte/interrupt.lisp:1.13 --- movitz/losp/muerte/interrupt.lisp:1.12 Fri Jun 4 06:33:50 2004 +++ movitz/losp/muerte/interrupt.lisp Sat Jun 5 19:10:55 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.12 2004/06/04 13:33:50 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.13 2004/06/06 02:10:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -106,6 +106,7 @@ ;; *DEST* iret branches to here. ;; we're now in the context of the interruptee. + (:cld) ;; Save/push thread-local values (:locally (:movl (:edi (:edi-offset num-values)) :ecx)) (:jecxz 'push-values-done) @@ -166,8 +167,7 @@ restart-atomical-block (:cmpb ,(bt:enum-value 'movitz::atomically-status :restart-primitive-function) :cl) (:jne 'not-simple-atomical-pf-restart) - (:testl ,(bt:enum-value 'movitz::atomically-status '(:eax :ebx :ecx :edx)) - :ecx) ; map of registers to restore + (:testl #xff00 :ecx) ; map of registers to restore (:jnz 'not-simple-atomical-pf-restart) (:sarl 16 :ecx) ; move atomically-status data into ECX (:movl (:edi (:ecx 4) ,(- (movitz:tag :null))) @@ -199,6 +199,10 @@ (:locally (:movl :ecx (:edi (:edi-offset atomically-status)))) (:movl (:ebp -36) :ecx) ; Load interruptee's atomically-esp.. (:locally (:movl :ecx (:edi (:edi-offset atomically-esp)))) ; ..and restore it. + + (:testl #x40 (:ebp 16)) ; Test EFLAGS bit DF + (:jnz 'atomically-jumper-return-dirty-registers) + (:movl (:ebp -28) :edi) (:movl (:ebp -24) :esi) (:movl (:ebp -16) :edx) @@ -215,6 +219,28 @@ (:movl :edi (:ebp 16)) (:movl :edi (:ebp 20)) (:movl (:ebp 0) :ebp) ; pop stack-frame + (:locally (:movl (:edi (:edi-offset atomically-esp)) :esp)) ; restore ESP + (:jmp (:esi :ebx ,(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0))) + + atomically-jumper-return-dirty-registers + ;; If the interruptee had DF set, then initialize all GP registers with + ;; safe values, keep EBP, set ESI=(EBP -4), and EDI is known-good EDI. + ;; DF will be cleared. + (:movl :edi :edx) + (:movl :edi :eax) + (:movl :edi :ecx) + + (:movl (:ebp -32) :ebx) ; atomically-status.. + (:shrl ,(- 16 movitz:+movitz-fixnum-shift+) :ebx) + + ;; Make stack safe before we exit interrupt-frame.. + (:movl :edi (:ebp 4)) + (:movl :edi (:ebp 8)) + (:movl :edi (:ebp 12)) + (:movl :edi (:ebp 16)) + (:movl :edi (:ebp 20)) + (:movl (:ebp 0) :ebp) ; pop interrupt-frame + (:movl (:ebp -4) :esi) (:locally (:movl (:edi (:edi-offset atomically-esp)) :esp)) ; restore ESP (:jmp (:esi :ebx ,(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0))) From ffjeld at common-lisp.net Sun Jun 6 03:00:13 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 05 Jun 2004 20:00:13 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10859 Modified Files: integers.lisp Log Message: Improved + for bignums. Date: Sat Jun 5 20:00:13 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.19 movitz/losp/muerte/integers.lisp:1.20 --- movitz/losp/muerte/integers.lisp:1.19 Sat Jun 5 18:53:48 2004 +++ movitz/losp/muerte/integers.lisp Sat Jun 5 20:00:13 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.19 2004/06/06 01:53:48 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.20 2004/06/06 03:00:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -117,26 +117,26 @@ (:jmp 'fix-fix-ok))) fix-fix-ok)) ((positive-bignum positive-fixnum) - (break "Hello?") - (+ y x)) + (funcall '+ y x)) ((positive-fixnum positive-bignum) (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) x) - (:testl :eax :eax) + (:compile-two-forms (:eax :ebx) y x) + (:testl :ebx :ebx) (:jz 'pfix-pbig-done) - (:compile-form (:result-mode :eax) y) (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) (:cmpl 1 :ecx) (:jne 'not-size1) (:compile-form (:result-mode :ecx) x) - (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) (:addl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx) - (:jc '(:sub-program () - (:break))) + (:jc 'retry-not-size1) (:call-global-constant box-u32-ecx) (:jmp 'pfix-pbig-done) + retry-not-size1 + (:compile-form (:result-mode :eax) y) + (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) not-size1 - (:declare-label-set retry-jumper (not-size1)) + (:declare-label-set retry-jumper (retry-not-size1)) (:locally (:movl :esp (:edi (:edi-offset atomically-esp)))) (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp) 'retry-jumper) @@ -146,8 +146,7 @@ (:call-global-constant get-cons-pointer) (:load-lexical (:lexical-binding y) :ebx) ; bignum (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) - (:leal ((:ecx #.movitz:+movitz-fixnum-factor+) - #.movitz:+movitz-fixnum-factor+) + (:leal ((:ecx #.movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+) :edx) (:movl 0 (:eax :edx ,movitz:+other-type-offset+)) ; MSB copy-bignum-loop @@ -166,11 +165,15 @@ (:addl 1 (:eax :ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) (:jc 'add-bignum-loop) add-bignum-done - (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) - (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) #+ignore ,movitz:+movitz-fixnum-factor+) - :ebx) -;;; (:cmpl 0 (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0) - + (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) + :ecx) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+) + :ecx) + (:cmpl 0 (:eax :ecx ,(+ -4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))) + (:je 'no-expansion) + (:addl #x10000 (:eax ,movitz:+other-type-offset+)) + (:addl ,movitz:+movitz-fixnum-factor+ :ecx) + no-expansion (:call-global-constant cons-commit) (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) (:edi (:edi-offset atomically-status)))) From ffjeld at common-lisp.net Sun Jun 6 03:01:19 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 05 Jun 2004 20:01:19 -0700 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11579 Modified Files: image.lisp Log Message: Added two more primitive-functions to run-time-block. Date: Sat Jun 5 20:01:19 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.35 movitz/image.lisp:1.36 --- movitz/image.lisp:1.35 Fri Jun 4 06:35:25 2004 +++ movitz/image.lisp Sat Jun 5 20:01:19 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.35 2004/06/04 13:35:25 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.36 2004/06/06 03:01:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -464,6 +464,18 @@ (atomically-esp :binary-type lu32 :initform 0) + (get-cons-pointer + :binary-type code-vector-word + :initform nil + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) + (cons-commit + :binary-type code-vector-word + :initform nil + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) (bochs-flags :binary-type lu32 :initform 0) From ffjeld at common-lisp.net Sun Jun 6 03:02:08 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 05 Jun 2004 20:02:08 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv11703 Modified Files: los0-gc.lisp Log Message: Implementation of new primitive-functions. Date: Sat Jun 5 20:02:08 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.16 movitz/losp/los0-gc.lisp:1.17 --- movitz/losp/los0-gc.lisp:1.16 Fri Jun 4 06:35:31 2004 +++ movitz/losp/los0-gc.lisp Sat Jun 5 20:02:08 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.16 2004/06/04 13:35:31 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.17 2004/06/06 03:02:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -54,12 +54,45 @@ (defun space-cons-pointer () (aref (%run-time-context-slot 'nursery-space) 0)) -(define-primitive-function los0-cons-pointer () - "" +(define-primitive-function muerte::get-cons-pointer () + "Return in EAX the next object location with space for EAX words, with tag 6. +Preserve ECX." (with-inline-assembly (:returns :multiple-values) - (:locally (:movl (:edi (:edi-offset nursery-space)) :eax)) - (:movl (:edx 2) :ecx))) - + retry + (:locally (:cmpl 0 (:edi (:edi-offset atomically-status)))) ; Atomically? + (:je '(:sub-program () + (:int 50))) ; This must be called inside atomically. + (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) + (:movl (:edx 2) :ebx) + (:leal (:ebx :eax 4) :eax) + (:andl -8 :eax) + (:cmpl #x3fff4 :eax) + (:jae '(:sub-program (probe-failed) + (:int 113) + (:jmp 'retry))) + (:movl :edi (:edx :ebx 8 #.movitz:+other-type-offset+)) + (:leal (:edx :ebx 8) :eax) + (:ret))) + +(define-primitive-function muerte::cons-commit () + "Commit allocation of ECX/fixnum words. +Preserve EAX and EBX." + (with-inline-assembly (:returns :multiple-values) + retry + (:locally (:cmpl 0 (:edi (:edi-offset atomically-status)))) ; Atomically? + (:je '(:sub-program () + (:int 50))) ; This must be called inside atomically. + (:addl #.movitz:+movitz-fixnum-factor+ :ecx) + (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) + (:andl -8 :ecx) + (:addl (:edx 2) :ecx) + (:cmpl #x3fff4 :ecx) + (:ja '(:sub-program (commit-failed) + (:int 113) + (:jmp 'retry))) + (:movl :ecx (:edx 2)) + (:leal (:edx :ecx) :ecx) + (:ret))) (define-primitive-function los0-fast-cons () "Allocate a cons cell from nursery-space." @@ -73,7 +106,7 @@ (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) (:movl (:edx 2) :ecx) (:cmpl #x3fff4 :ecx) - (:jge '(:sub-program (allocation-failed) + (:ja '(:sub-program (allocation-failed) ;; Exit thread-atomical (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) (:edi (:edi-offset atomically-status)))) @@ -133,7 +166,7 @@ retry (:compile-form (:result-mode :ebx) clumps) (:declare-label-set retry-jumper (retry)) - (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp) + (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t) 'retry-jumper) (:edi (:edi-offset atomically-status)))) (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) From ffjeld at common-lisp.net Sun Jun 6 03:02:45 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 05 Jun 2004 20:02:45 -0700 Subject: [movitz-cvs] CVS update: movitz/procfs-image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11810 Modified Files: procfs-image.lisp Log Message: Minor fix for backtrace. Date: Sat Jun 5 20:02:45 2004 Author: ffjeld Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.6 movitz/procfs-image.lisp:1.7 --- movitz/procfs-image.lisp:1.6 Tue Jun 1 08:16:54 2004 +++ movitz/procfs-image.lisp Sat Jun 5 20:02:45 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.6 2004/06/01 15:16:54 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.7 2004/06/06 03:02:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -174,16 +174,13 @@ ;; (search-image-funobj (image-register32 *image* :eip)) (format t "~&Current ESI: #x~X.~%" (image-register32 *image* :esi)) - (loop with unknown-counter = 0 - for stack-frame = (current-stack-frame) then (previous-stack-frame stack-frame) + (loop for stack-frame = (current-stack-frame) then (previous-stack-frame stack-frame) unless (zerop (mod stack-frame 4)) do (format t "[frame #x~8,'0x]" stack-frame) - and do (loop-finish) + (loop-finish) do (let ((movitz-name (funobj-name (stack-frame-funobj stack-frame)))) (typecase movitz-name (null - (when (< 10 (incf unknown-counter)) - (return-from backtrace nil)) (write-string "?") (let* ((r (stack-frame-return-address stack-frame)) (eax (get-word (+ (* 4 (interrupt-frame-index :eax)) stack-frame))) From ffjeld at common-lisp.net Sun Jun 6 10:24:29 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 06 Jun 2004 03:24:29 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv25792 Modified Files: integers.lisp Log Message: Starting work on *. Date: Sun Jun 6 03:24:29 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.20 movitz/losp/muerte/integers.lisp:1.21 --- movitz/losp/muerte/integers.lisp:1.20 Sat Jun 5 20:00:13 2004 +++ movitz/losp/muerte/integers.lisp Sun Jun 6 03:24:29 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.20 2004/06/06 03:00:13 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.21 2004/06/06 10:24:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -719,48 +719,36 @@ (:andb #.(cl:logxor #xff movitz::+movitz-fixnum-zmask+) :al))) (t (if (= 0 integer) 0 (error "Illegal ash count: ~D" count))))) - ;;; Multiplication -(define-compiler-macro *%2op (&whole form &environment env factor1 factor2) - (cond - ((and (movitz:movitz-constantp factor1 env) - (movitz:movitz-constantp factor2 env)) - (* (movitz:movitz-eval factor1 env) - (movitz:movitz-eval factor2 env))) - ((movitz:movitz-constantp factor2 env) - `(*%2op ,(movitz:movitz-eval factor2 env) ,factor1)) - ((movitz:movitz-constantp factor1 env) - (let ((f1 (movitz:movitz-eval factor1 env))) - (check-type f1 fixnum) - (case f1 - (0 `(progn ,factor2 0)) - (1 factor2) - (2 `(ash ,factor2 1)) - (t `(with-inline-assembly (:returns :eax :type integer) - (:compile-form (:result-mode :eax) ,factor2) - (:testb #.movitz::+movitz-fixnum-zmask+ :al) - (:jnz '(:sub-program () (:int 107))) - (:imull ,f1 :eax :eax) - (:into)))))) - (t `(no-macro-call * ,factor1 ,factor2)))) - -;;;(defun *%2op (factor1 factor2) -;;; (check-type factor1 fixnum) -;;; (check-type factor2 fixnum) -;;; (with-inline-assembly (:returns :eax) -;;; (:compile-form (:result-mode :eax) factor1) -;;; (:compile-form (:result-mode :ebx) factor2) -;;; (:sarl #.movitz::+movitz-fixnum-shift+ :eax) -;;; (:imull :ebx :eax :edx) -;;; (:into))) - -(define-compiler-macro * (&whole form &rest operands) +(define-compiler-macro * (&whole form &rest operands &environment env) (case (length operands) (0 0) (1 (first operands)) - (2 `(*%2op ,(first operands) ,(second operands))) - (t `(* (*%2op ,(first operands) ,(second operands)) ,@(cddr operands))))) + (2 (let ((factor1 (first operands)) + (factor2 (second operands))) + (cond + ((and (movitz:movitz-constantp factor1 env) + (movitz:movitz-constantp factor2 env)) + (* (movitz:movitz-eval factor1 env) + (movitz:movitz-eval factor2 env))) + ((movitz:movitz-constantp factor2 env) + `(* ,(movitz:movitz-eval factor2 env) ,factor1)) + ((movitz:movitz-constantp factor1 env) + (let ((f1 (movitz:movitz-eval factor1 env))) + (check-type f1 fixnum) + (case f1 + (0 `(progn ,factor2 0)) + (1 factor2) + (2 `(ash ,factor2 1)) + (t `(with-inline-assembly (:returns :eax :type integer) + (:compile-form (:result-mode :eax) ,factor2) + (:testb #.movitz::+movitz-fixnum-zmask+ :al) + (:jnz '(:sub-program () (:int 107))) + (:imull ,f1 :eax :eax) + (:into)))))) + (t `(no-macro-call * ,factor1 ,factor2))))) + (t `(* (* ,(first operands) ,(second operands)) ,@(cddr operands))))) (defun * (&rest factors) (numargs-case @@ -782,7 +770,7 @@ (declare (dynamic-extent factors)) (if (null factors) 1 - (reduce '*%2op factors))))) + (reduce '* factors))))) ;;; Division @@ -1353,7 +1341,7 @@ (defun print-bignum (x) (check-type x bignum) - (loop for i from 0 to (%bignum-bigits x) - do (format t "~8,'0X " (memref x -6 i :unsigned-byte32))) + (dotimes (i (1+ (%bignum-bigits x))) + (format t "~8,'0X " (memref x -6 i :unsigned-byte32))) (terpri) (values)) From ffjeld at common-lisp.net Sun Jun 6 11:32:09 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 06 Jun 2004 04:32:09 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10391 Modified Files: memref.lisp Log Message: Have memref-int :unsigned-byte32 box a bignum if necessary. Date: Sun Jun 6 04:32:09 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.13 movitz/losp/muerte/memref.lisp:1.14 --- movitz/losp/muerte/memref.lisp:1.13 Wed Apr 14 13:05:26 2004 +++ movitz/losp/muerte/memref.lisp Sun Jun 6 04:32:09 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.13 2004/04/14 20:05:26 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.14 2004/06/06 11:32:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -603,11 +603,7 @@ (:addl :ecx :eax) (:shrl ,movitz::+movitz-fixnum-shift+ :eax) ; scale down address (,prefixes :movl (:eax) :ecx) - (:cmpl ,movitz::+movitz-most-positive-fixnum+ :ecx) - (:jg '(:sub-program (overflow) (:int 4))) - (:leal ((:ecx ,movitz::+movitz-fixnum-factor+) - :edi ,(- (movitz::image-nil-word movitz::*image*))) - :eax))) + (:call-global-constant box-u32-ecx))) (:unsigned-byte16 (cond ((and (eq 0 offset) (eq 0 index)) From ffjeld at common-lisp.net Sun Jun 6 14:25:22 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 06 Jun 2004 07:25:22 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11557 Modified Files: integers.lisp Log Message: Multiplication of two fixnums, result overflowing into bignums, seems to work. Date: Sun Jun 6 07:25:22 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.21 movitz/losp/muerte/integers.lisp:1.22 --- movitz/losp/muerte/integers.lisp:1.21 Sun Jun 6 03:24:29 2004 +++ movitz/losp/muerte/integers.lisp Sun Jun 6 07:25:22 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.21 2004/06/06 10:24:29 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.22 2004/06/06 14:25:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -754,18 +754,76 @@ (numargs-case (1 (x) x) (2 (x y) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) x) - (:compile-form (:result-mode :ebx) y) - (:movl :eax :ecx) - (:orl :ebx :ecx) - (:testb #.movitz::+movitz-fixnum-zmask+ :cl) - (:jne '(:sub-program (not-fixnum) - (:int 107))) - (:movl :ebx :ecx) - (:sarl #.movitz::+movitz-fixnum-shift+ :ecx) - (:imull :ecx :eax :edx) - (:into))) + (macrolet + ((do-it () + `(number-double-dispatch (x y) + ((fixnum fixnum) + (let (d0 d1) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ecx) x y) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) + (:std) + (:imull :ecx :eax :edx) + (:jno 'fixnum-result) ; most likely/optimized path. + (:cmpl ,movitz::+movitz-fixnum-factor+ :edx) + (:jc 'u32-result) + (:cmpl #xfffffffc :edx) + (:ja 'u32-negative-result) + (:jne 'two-bigits) + (:testl :eax :eax) + (:jnz 'u32-negative-result) + ;; The result requires 2 bigits.. + two-bigits + (:shll ,movitz::+movitz-fixnum-shift+ :edx) ; guaranteed won't overflow. + (:cld) + (:store-lexical (:lexical-binding d0) :eax :type fixnum) + (:store-lexical (:lexical-binding d1) :edx :type fixnum) + (:compile-form (:result-mode :eax) + (malloc-data-words 3)) + (:movl ,(dpb 2 (byte 16 16) (movitz:tag :bignum 0)) + (:eax ,movitz:+other-type-offset+)) + (:load-lexical (:lexical-binding d0) :ecx) + (:movl :ecx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:load-lexical (:lexical-binding d1) :ecx) + (:sarl ,movitz:+movitz-fixnum-shift+ + :ecx) + (:shrdl ,movitz:+movitz-fixnum-shift+ :ecx + (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:sarl ,movitz:+movitz-fixnum-shift+ + :ecx) + (:movl :ecx (:eax ,(+ 4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))) + (:jns 'fixnum-done) + ;; if result was negative, we must negate bignum + (:notl (:eax ,(+ 4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))) + (:negl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:cmc) + (:adcl 0 (:eax ,(+ 4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))) + (:xorl #xff00 (:eax ,movitz:+other-type-offset+)) + (:jmp 'fixnum-done) + + u32-result + (:movl :eax :ecx) + (:shrdl ,movitz::+movitz-fixnum-shift+ :edx :ecx) + (:movl :edi :edx) + (:cld) + (:call-global-constant box-u32-ecx) + (:jmp 'fixnum-done) + + u32-negative-result + (:movl :eax :ecx) + (:shrdl ,movitz::+movitz-fixnum-shift+ :edx :ecx) + (:movl :edi :edx) + (:cld) + (:negl :ecx) + (:call-global-constant box-u32-ecx) + (:xorl #xff00 (:eax ,movitz:+other-type-offset+)) + (:jmp 'fixnum-done) + + fixnum-result + (:movl :edi :edx) + (:cld) + fixnum-done)))))) + (do-it))) (t (&rest factors) (declare (dynamic-extent factors)) (if (null factors) From ffjeld at common-lisp.net Sun Jun 6 15:12:41 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 06 Jun 2004 08:12:41 -0700 Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24388 Modified Files: special-operators.lisp Log Message: The (special) operator +%2op isn't quite up to speed. This patch removes one of the most nasty assumptions about fixnums. Date: Sun Jun 6 08:12:41 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.22 movitz/special-operators.lisp:1.23 --- movitz/special-operators.lisp:1.22 Fri Apr 16 03:24:54 2004 +++ movitz/special-operators.lisp Sun Jun 6 08:12:40 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.22 2004/04/16 10:24:54 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.23 2004/06/06 15:12:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1110,12 +1110,9 @@ (let ((constant-term2 (eval-form term2 env))) (check-type constant-term2 (signed-byte 30)) (compile-constant-add constant-term2 term1))) - (t (compiler-call #'compile-form-unprotected + (t (compiler-call #'compile-apply-symbol :forward all - :form `(muerte::with-inline-assembly (:returns :eax :side-effects nil) - (:compile-two-forms (:ebx :eax) ,term1 ,term2) - (:addl :ebx :eax) - (:into)))))))) + :form `(muerte.cl:+ ,term1 ,term2))))))) (define-special-operator muerte::include (&form form) (let ((*require-dependency-chain* From ffjeld at common-lisp.net Mon Jun 7 10:39:10 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 07 Jun 2004 03:39:10 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3186 Modified Files: integers.lisp Log Message: Added multiplication of fixnum with bignum. Date: Mon Jun 7 03:39:10 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.22 movitz/losp/muerte/integers.lisp:1.23 --- movitz/losp/muerte/integers.lisp:1.22 Sun Jun 6 07:25:22 2004 +++ movitz/losp/muerte/integers.lisp Mon Jun 7 03:39:10 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.22 2004/06/06 14:25:22 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.23 2004/06/07 10:39:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -85,6 +85,7 @@ `(+ (+%2op ,(first operands) ,(second operands)) ,@(cddr operands)))))) (defun + (&rest terms) + (declare (without-check-stack-limit)) (numargs-case (1 (x) x) (2 (x y) @@ -822,7 +823,84 @@ fixnum-result (:movl :edi :edx) (:cld) - fixnum-done)))))) + fixnum-done))) + (((eql 0) t) 0) + (((eql 1) t) y) + ((t fixnum) (* y x)) + ((fixnum bignum) + (let (r) + (with-inline-assembly (:returns :eax) + retry + (:declare-label-set retry-jumper (retry)) + (:locally (:movl :esp (:edi (:edi-offset atomically-esp)))) + (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp) + 'retry-jumper) + (:edi (:edi-offset atomically-status)))) + + (:compile-form (:result-mode :eax) y) + (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) + :ecx) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) + ,(* 2 movitz:+movitz-fixnum-factor+)) + :eax) + (:call-global-constant get-cons-pointer) ; New bignum into EAX + + (:load-lexical (:lexical-binding y) :ebx) ; bignum + (:movl (:ebx ,movitz:+other-type-offset+) :ecx) + (:movl :ecx (:eax ,movitz:+other-type-offset+)) + (:store-lexical (:lexical-binding r) :eax :type bignum) + + (:movl :eax :ebx) ; r into ebx + (:xorl :ecx :ecx) + (:xorl :edx :edx) ; initial carry + (:std) ; Make EAX, EDX, ESI non-GC-roots. + (:compile-form (:result-mode :esi) x) + (:sarl ,movitz:+movitz-fixnum-shift+ :esi) + (:jns 'multiply-loop) + (:negl :esi) ; can't overflow + multiply-loop + (:movl :edx (:ebx (:ecx 4) ; new + ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:compile-form (:result-mode :ebx) y) + (:movl (:ebx (:ecx 4) ; old + ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) + :eax) + + (:mull :esi :eax :edx) + (:compile-form (:result-mode :ebx) r) + (:addl :eax + (:ebx (:ecx 4) + ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:adcl 0 :edx) + (:addl 1 :ecx) + (:cmpw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:ja 'multiply-loop) + (:testl :edx :edx) + (:jz 'no-carry-expansion) + (:movl :edx + (:ebx (:ecx 4) + ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:addl 1 :ecx) + (:movw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + no-carry-expansion + (:movl (:ebp -4) :esi) + (:movl :ebx :eax) + (:movl :edi :edx) + (:cld) ; EAX, EDX, and ESI are GC roots again. + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) + ,movitz:+movitz-fixnum-factor+) + :ecx) + (:call-global-constant cons-commit) + (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) + (:edi (:edi-offset atomically-status)))) + (:compile-form (:result-mode :ebx) x) + (:testl :ebx :ebx) + (:jns 'positive-result) + ;; Negate the resulting bignum + (:xorl #xff00 (:eax ,movitz:+other-type-offset+)) + positive-result + ))) + ))) (do-it))) (t (&rest factors) (declare (dynamic-extent factors)) @@ -875,6 +953,8 @@ (values number 0)) (t (number divisor) (number-double-dispatch (number divisor) + ((t (eql 1)) + number) ((fixnum fixnum) (with-inline-assembly (:returns :multiple-values) (:compile-form (:result-mode :eax) number) @@ -894,16 +974,16 @@ `(let (r n) (with-inline-assembly (:returns :multiple-values) (:compile-form (:result-mode :ebx) number) - (:cmpw 1 (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:cmpw 1 (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) (:jne 'not-size1) (:compile-form (:result-mode :ecx) divisor) - (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) (:std) - (:movl (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :eax) + (:movl (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :eax) (:xorl :edx :edx) (:divl :ecx :eax :edx) (:movl :eax :ecx) - (:shll #.movitz:+movitz-fixnum-shift+ :edx) + (:shll ,movitz:+movitz-fixnum-shift+ :edx) (:movl :edi :eax) (:cld) (:pushl :edx) @@ -912,7 +992,7 @@ (:jmp 'done) not-size1 (:compile-form (:result-mode :ebx) number) - (:movzxw (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) + (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) (:declare-label-set retry-jumper (not-size1)) @@ -921,10 +1001,10 @@ 'retry-jumper) (:edi (:edi-offset atomically-status)))) - (:leal ((:ecx #.movitz:+movitz-fixnum-factor+) #.movitz:+movitz-fixnum-factor+) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+) :eax) ; Number of words (:call-global-constant get-cons-pointer) ; New bignum into EAX - + (:store-lexical (:lexical-binding r) :eax :type bignum) (:compile-form (:result-mode :ebx) number) From ffjeld at common-lisp.net Mon Jun 7 22:09:24 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 07 Jun 2004 15:09:24 -0700 Subject: [movitz-cvs] CVS update: movitz/compiler-types.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv7413 Modified Files: compiler-types.lisp Log Message: Slight improvement of type-specifier-nth-value. Date: Mon Jun 7 15:09:24 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.12 movitz/compiler-types.lisp:1.13 --- movitz/compiler-types.lisp:1.12 Sun Apr 18 17:29:35 2004 +++ movitz/compiler-types.lisp Mon Jun 7 15:09:24 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.12 2004/04/19 00:29:35 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.13 2004/06/07 22:09:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -45,9 +45,10 @@ ((< number (length reqs)) (nth number reqs)) ((< number (+ (length reqs) (length opts))) - `(or null ,(nth (- number (length reqs)) opts))) + (let ((x (nth (- number (length reqs)) opts))) + (if (eq x t) t `(or null ,x)))) (rest - `(or null ,rest)) + (if (eq rest t) t `(or null ,rest))) (t 'null)))))) (defun type-specifier-primary (type-specifier) From ffjeld at common-lisp.net Mon Jun 7 22:09:56 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 07 Jun 2004 15:09:56 -0700 Subject: [movitz-cvs] CVS update: movitz/environment.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv7562 Modified Files: environment.lisp Log Message: Don't return the second value from gethash. Date: Mon Jun 7 15:09:56 2004 Author: ffjeld Index: movitz/environment.lisp diff -u movitz/environment.lisp:1.5 movitz/environment.lisp:1.6 --- movitz/environment.lisp:1.5 Tue Feb 17 12:24:00 2004 +++ movitz/environment.lisp Mon Jun 7 15:09:56 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 3 11:40:15 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: environment.lisp,v 1.5 2004/02/17 20:24:00 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.6 2004/06/07 22:09:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -438,7 +438,7 @@ ;;; Accessor: movitz-env-symbol-function (defun movitz-env-symbol-function (symbol &optional env) - (gethash symbol (movitz-environment-function-cells (or env *movitz-global-environment*)))) + (values (gethash symbol (movitz-environment-function-cells (or env *movitz-global-environment*))))) (defun (setf movitz-env-symbol-function) (value symbol &optional env) (setf (gethash symbol (movitz-environment-function-cells (or env *movitz-global-environment*))) From ffjeld at common-lisp.net Mon Jun 7 22:10:54 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 07 Jun 2004 15:10:54 -0700 Subject: [movitz-cvs] CVS update: movitz/movitz-mode.el Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv8622 Modified Files: movitz-mode.el Log Message: Minor edit. Date: Mon Jun 7 15:10:54 2004 Author: ffjeld Index: movitz/movitz-mode.el diff -u movitz/movitz-mode.el:1.6 movitz/movitz-mode.el:1.7 --- movitz/movitz-mode.el:1.6 Mon May 24 07:58:17 2004 +++ movitz/movitz-mode.el Mon Jun 7 15:10:54 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Sep 27 18:12:17 2001 ;;;; -;;;; $Id: movitz-mode.el,v 1.6 2004/05/24 14:58:17 ffjeld Exp $ +;;;; $Id: movitz-mode.el,v 1.7 2004/06/07 22:10:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -63,7 +63,7 @@ (point)) (progn (forward-sexp 1) (point))))) - (if (and (string-equal "method" definition-type) + (if (and (equalp "method" definition-type) (char-equal 58 (string-to-char lambda-list))) (let ((qualifier lambda-list) ;; XXX we only deal with one (potential) qualifier.. From ffjeld at common-lisp.net Mon Jun 7 22:13:12 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 07 Jun 2004 15:13:12 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9497 Modified Files: interrupt.lisp Log Message: Be slightly more clever when dealing with stack exhausted exceptions. Date: Mon Jun 7 15:13:12 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.13 movitz/losp/muerte/interrupt.lisp:1.14 --- movitz/losp/muerte/interrupt.lisp:1.13 Sat Jun 5 19:10:55 2004 +++ movitz/losp/muerte/interrupt.lisp Mon Jun 7 15:13:12 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.13 2004/06/06 02:10:55 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.14 2004/06/07 22:13:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -291,8 +291,9 @@ $eax $ecx)) (62 (error "Trying to save too many values: ~@Z." $ecx)) ((5 55) - (let* ((stack (%run-time-context-slot 'movitz::stack-vector)) - (old-bottom (stack-bottom)) + (let* ((old-bottom (prog1 (stack-bottom) + (setf (stack-bottom) 0))) + (stack (%run-time-context-slot 'movitz::stack-vector)) (real-bottom (- (object-location stack) 2)) (stack-left (- old-bottom real-bottom)) (new-bottom (cond From ffjeld at common-lisp.net Mon Jun 7 22:14:06 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 07 Jun 2004 15:14:06 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette-compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10506 Modified Files: los-closette-compiler.lisp Log Message: Be a bit more defensive in slot-location. Date: Mon Jun 7 15:14:06 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette-compiler.lisp diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.13 movitz/losp/muerte/los-closette-compiler.lisp:1.14 --- movitz/losp/muerte/los-closette-compiler.lisp:1.13 Wed May 19 08:02:50 2004 +++ movitz/losp/muerte/los-closette-compiler.lisp Mon Jun 7 15:14:06 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Aug 29 13:15:11 2002 ;;;; -;;;; $Id: los-closette-compiler.lisp,v 1.13 2004/05/19 15:02:50 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.14 2004/06/07 22:14:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -468,28 +468,37 @@ ;;; + (defvar *slot-location-nesting* 0) (defun slot-location (class slot-name) - (cond - ((and (eq slot-name 'effective-slots) - (eq class *the-class-standard-class*)) - (position 'effective-slots *the-slots-of-standard-class* - :key #'slot-definition-name)) - ((eq class (movitz-find-class 'standard-effective-slot-definition nil)) - (or (position slot-name '(name type initform initfunction initargs allocation location)) - (error "No slot ~S in ~S." slot-name (movitz-class-name class)))) - (t (let ((slot (find slot-name - (std-slot-value class 'effective-slots) - :key #'slot-definition-name))) - (if (null slot) - (error "Closette compiler: The slot ~S is missing from the class ~S." - slot-name class) - (let ((pos (position slot - (remove-if-not #'instance-slot-p - (std-slot-value class 'effective-slots))))) - (if (null pos) - (error "Closette compiler: The slot ~S is not an instance slot in the class ~S." - slot-name class) - pos))))))) + (when (< 10 *slot-location-nesting*) + (break "Unbounded slot-location?")) + (let ((*slot-location-nesting* (1+ *slot-location-nesting*))) + (cond + ((and (eq slot-name 'effective-slots) + (eq class *the-class-standard-class*)) + (position 'effective-slots *the-slots-of-standard-class* + :key #'slot-definition-name)) + ((eq class (movitz-find-class 'standard-effective-slot-definition nil)) + (or (position slot-name '(name type initform initfunction initargs allocation location)) + (error "No slot ~S in ~S." slot-name (movitz-class-name class)))) + (t #+ignore + (when (and (eq slot-name 'effective-slots) + (subclassp class *the-class-standard-class*)) + (break "Looking for slot ~S in class ~S, while std-class is ~S." + slot-name class *the-class-standard-class*)) + (let ((slot (find slot-name + (std-slot-value class 'effective-slots) + :key #'slot-definition-name))) + (if (null slot) + (error "Closette compiler: The slot ~S is missing from the class ~S." + slot-name class) + (let ((pos (position slot + (remove-if-not #'instance-slot-p + (std-slot-value class 'effective-slots))))) + (if (null pos) + (error "Closette compiler: The slot ~S is not an instance slot in the class ~S." + slot-name class) + pos)))))))) (defun movitz-class-of (instance) (std-instance-class instance)) From ffjeld at common-lisp.net Mon Jun 7 22:16:53 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 07 Jun 2004 15:16:53 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12007 Modified Files: primitive-functions.lisp Log Message: Changed the semantics of unbox-u32 somewhat. Date: Mon Jun 7 15:16:53 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.19 movitz/losp/muerte/primitive-functions.lisp:1.20 --- movitz/losp/muerte/primitive-functions.lisp:1.19 Mon May 24 12:34:34 2004 +++ movitz/losp/muerte/primitive-functions.lisp Mon Jun 7 15:16:53 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.19 2004/05/24 19:34:34 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.20 2004/06/07 22:16:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -516,23 +516,20 @@ (:int 107))) ; not implemented by default! (define-primitive-function unbox-u32 () - "Coerce EAX into a u32 in ECX, or signal type error. -Preserve EAX, EBX, and EDX." + "Load (ldb (byte 32 0) EAX) into ECX." (macrolet ((do-it () `(with-inline-assembly (:returns :multiple-values) - (:testl ,(logior #x80000000 movitz:+movitz-fixnum-zmask+) - :eax) + (:testb 3 :al) (:jnz 'not-fixnum) (:movl :eax :ecx) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) (:ret) not-fixnum (:leal (:eax ,(- (movitz:tag :other))) :ecx) (:testb 7 :cl) (:jnz 'fail) - (:cmpl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0)) - (:eax ,movitz:+other-type-offset+)) + (:cmpb ,(movitz:tag :bignum) (:eax ,movitz:+other-type-offset+)) (:jne 'fail) (:movl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx) From ffjeld at common-lisp.net Mon Jun 7 22:18:37 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 07 Jun 2004 15:18:37 -0700 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv12896 Modified Files: compiler.lisp Log Message: Changed some details regarding how variables are located in registers and stack. Date: Mon Jun 7 15:18:37 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.61 movitz/compiler.lisp:1.62 --- movitz/compiler.lisp:1.61 Mon May 24 12:10:12 2004 +++ movitz/compiler.lisp Mon Jun 7 15:18:37 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.61 2004/05/24 19:10:12 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.62 2004/06/07 22:18:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2227,13 +2227,8 @@ (defclass closure-binding (function-binding located-binding) ()) (defclass lambda-binding (function-binding) ()) -#+ignore (defclass temporary-name (located-binding) - ;; Is the value that this binding is bound to dynamic-extent? - (#+ignore - (stack-frame-allocated-p ; also a property-list - :initform nil - :accessor stack-frame-allocated-p))) + ()) (defclass borrowed-binding (located-binding) ((reference-slot @@ -2518,6 +2513,7 @@ free later, with a more specified frame-map." (loop with free-so-far = free-registers repeat distance for i in pc + while (not (null free-so-far)) doing (cond ((and (instruction-is i :init-lexvar) @@ -2534,20 +2530,34 @@ (member x protect-registers)))) free-so-far))))) (t (case (instruction-is i) - ((nil :call) - (return nil)) + ((nil) + (return nil)) ; a label, most likely + ((:call) + (setf free-so-far + (remove-if (lambda (r) + (not (eq r :push))) + free-so-far))) ((:into :clc :stc :cld :std)) - ((:jnz :je :jne :jz)) + ((:jnz :je :jne :jz :jge) + (setf free-so-far + (remove :push free-so-far))) + ((:pushl :popl) + (setf free-so-far + (remove-if (lambda (r) + (or (eq r :push) + (tree-search i r))) + free-so-far))) ((:outb) (setf free-so-far (set-difference free-so-far '(:eax :edx)))) ((:movb :testb :andb :cmpb) (setf free-so-far (remove-if (lambda (r) - (or (tree-search i r) - (tree-search i (register32-to-low8 r)))) + (and (not (eq r :push)) + (or (tree-search i r) + (tree-search i (register32-to-low8 r))))) free-so-far))) - ((:shrl :cmpl :pushl :popl :leal :movl :testl :andl :addl :subl :imull) + ((:sarl :shrl :cmpl :leal :movl :testl :andl :addl :subl :imull) (setf free-so-far (remove-if (lambda (r) (tree-search i r)) @@ -2558,11 +2568,15 @@ (return (values nil t))) (let ((exp (expand-extended-code i funobj frame-map))) (when (tree-search exp '(:call :local-function-init)) - (return nil)) + (setf free-so-far + (remove-if (lambda (r) + (not (eq r :push))) + free-so-far))) (setf free-so-far (remove-if (lambda (r) - (or (tree-search exp r) - (tree-search exp (register32-to-low8 r)))) + (and (not (eq r :push)) + (or (tree-search exp r) + (tree-search exp (register32-to-low8 r))))) free-so-far)))) ((:local-function-init) (destructuring-bind (binding) @@ -2572,6 +2586,7 @@ (t (warn "Dist ~D stopped by ~A" distance i) (return nil))))) + ;; do (warn "after ~A: ~A" i free-so-far) finally (return free-so-far))) (defun try-locate-in-register (binding var-counts funobj frame-map) @@ -2581,7 +2596,7 @@ (let* ((count-init-pc (gethash binding var-counts)) (count (car count-init-pc)) (init-pc (cdr count-init-pc))) - ;; (warn "count: ~D, init-pc: ~{~&~A~}" count init-pc) + ;; (warn "b ~S: count: ~D, init-pc: ~{~&~A~}" binding count init-pc) (cond ((binding-lended-p binding) ;; We can't lend a register. @@ -2599,7 +2614,7 @@ (member binding (find-read-bindings i) :test #'binding-eql)) (cdr init-pc) - :end 7)) + :end 15)) (binding-destination (third load-instruction)) (distance (position load-instruction (cdr init-pc)))) (multiple-value-bind (free-registers more-later-p) @@ -2631,6 +2646,18 @@ (first free-registers-no-ecx)) (more-later-p (values nil :not-now)) + ((and distance (typep binding 'temporary-name)) + ;; We might push/pop this variable + (multiple-value-bind (push-available-p maybe-later) + (compute-free-registers (cdr init-pc) distance funobj frame-map + :free-registers '(:push)) + ;; (warn "pushing.. ~S ~A ~A" binding push-available-p maybe-later) + (cond + (push-available-p + (values :push)) + (maybe-later + (values nil :not-now)) + (t (values nil :never))))) (t (values nil :never)))))))) (t (values nil :never))))) @@ -2826,13 +2853,20 @@ (t (assert (eq status :never)))))))) do (when (and try-again (not did-assign)) (let ((binding (or (find-if (lambda (b) + (and (typep b 'positional-function-argument) + (= 0 (function-argument-argnum b)) + (not (new-binding-located-p b frame-map)))) + bindings-fun-arg-sorted) + (find-if (lambda (b) + (and (typep b 'positional-function-argument) + (= 1 (function-argument-argnum b)) + (not (new-binding-located-p b frame-map)))) + bindings-fun-arg-sorted) + (find-if (lambda (b) (and (not (new-binding-located-p b frame-map)) (not (typep b 'function-argument)))) bindings-register-goodness-sort - :from-end t) - (find-if (lambda (b) - (not (new-binding-located-p b frame-map))) - bindings-fun-arg-sorted)))) + :from-end t)))) (when binding (setf (new-binding-location binding frame-map) (post-incf stack-frame-position)) @@ -3142,6 +3176,10 @@ `((:movl (-1 ,(single-value-register result-mode)) ,(single-value-register result-mode)))))) (t (ecase lexb-location + (:push + (assert (member result-mode '(:eax :ebx :ecx :edx))) + (assert (not indirect-p)) + `((:popl ,result-mode))) (:eax (assert (not indirect-p)) (ecase result-mode @@ -3354,6 +3392,8 @@ (if (integerp location) `((:movl ,source (:ebp ,(stack-frame-offset location)))) (ecase location + ((:push) + `((:pushl ,source))) ((:eax :ebx :ecx :edx) (unless (eq source location) `((:movl ,source ,location)))) @@ -5267,14 +5307,22 @@ (t #+ignore (when (and (not (tree-search code1 reg0)) (not (tree-search code1 :call))) (warn "got b: ~S ~S for ~S: ~{~&~A~}" form0 form1 reg0 code1)) - (append (compile-form form0 funobj env nil :push) - (compiler-call #'compile-form - :form form1 - :funobj funobj - :env env - :result-mode reg1 - :with-stack-used 1) - `((:popl ,reg0))))) + (let ((binding (make-instance 'temporary-name :name (gensym "tmp-"))) + (xenv (make-local-movitz-environment env funobj))) + (movitz-env-add-binding xenv binding) + (append (compiler-call #'compile-form + :form form0 + :funobj funobj + :env env + :result-mode reg0) + `((:init-lexvar ,binding :init-with-register ,reg0 + :init-with-type ,(type-specifier-primary type0))) + (compiler-call #'compile-form + :form form1 + :funobj funobj + :env xenv + :result-mode reg1) + `((:load-lexical ,binding ,reg0)))))) (and functional0 functional1) t (compiler-values-list (all0)) @@ -5624,7 +5672,8 @@ (defun can-expand-extended-p (extended-instruction frame-map) "Given frame-map, can we expand i at this point?" (and (every (lambda (b) - (new-binding-located-p (binding-target b) frame-map)) + (or (typep (binding-target b) 'constant-object-binding) + (new-binding-located-p (binding-target b) frame-map))) (find-read-bindings extended-instruction)) (let ((written-binding (find-written-binding-and-type extended-instruction))) (or (not written-binding) From ffjeld at common-lisp.net Tue Jun 8 20:06:26 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 08 Jun 2004 13:06:26 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7407 Modified Files: basic-macros.lisp Log Message: Minor tweak to check-type. Date: Tue Jun 8 13:06:26 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.19 movitz/losp/muerte/basic-macros.lisp:1.20 --- movitz/losp/muerte/basic-macros.lisp:1.19 Fri May 21 02:40:48 2004 +++ movitz/losp/muerte/basic-macros.lisp Tue Jun 8 13:06:26 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.19 2004/05/21 09:40:48 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.20 2004/06/08 20:06:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -543,7 +543,7 @@ (assert (typep (movitz::eval-form place env) type)) nil) (t (if (member type '(standard-gf-instance function pointer atom - integer fixnum cons symbol character null list + integer fixnum positive-fixnum cons symbol character null list string vector simple-vector vector-u8 vector-u16)) `(unless (typep ,place ',type) (with-inline-assembly (:returns :non-local-exit) From ffjeld at common-lisp.net Tue Jun 8 20:07:02 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 08 Jun 2004 13:07:02 -0700 Subject: [movitz-cvs] CVS update: movitz/packages.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv7822 Modified Files: packages.lisp Log Message: More symbols. Date: Tue Jun 8 13:07:02 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.24 movitz/packages.lisp:1.25 --- movitz/packages.lisp:1.24 Wed Jun 2 16:52:26 2004 +++ movitz/packages.lisp Tue Jun 8 13:07:02 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.24 2004/06/02 23:52:26 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.25 2004/06/08 20:07:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1316,6 +1316,7 @@ #:+movitz-most-positive-fixnum+ #:+movitz-most-negative-fixnum+ #:+movitz-fixnum-factor+ + #:+movitz-fixnum-bits+ #:+movitz-fixnum-shift+ #:+movitz-fixnum-zmask+ #:+scan-skip-word+ @@ -1333,6 +1334,7 @@ #:movitz-symbol #:movitz-string + #:movitz-bignum #:movitz-character #:movitz-char From ffjeld at common-lisp.net Tue Jun 8 20:11:13 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 08 Jun 2004 13:11:13 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12459 Modified Files: integers.lisp Log Message: Implemented ldb wrt. bignums. It does not work for negative bignums yet. Date: Tue Jun 8 13:11:13 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.25 movitz/losp/muerte/integers.lisp:1.26 --- movitz/losp/muerte/integers.lisp:1.25 Tue Jun 8 01:15:26 2004 +++ movitz/losp/muerte/integers.lisp Tue Jun 8 13:11:13 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.25 2004/06/08 08:15:26 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.26 2004/06/08 20:11:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1273,19 +1273,21 @@ (t `(logior (logior%2op ,(first constant-folded-integers) ,(second constant-folded-integers)) ,@(cddr constant-folded-integers)))))) -(defun logxor%2op (x y) - (check-type x fixnum) - (check-type y fixnum) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) x) - (:compile-form (:result-mode :ebx) y) - (:xorl :ebx :eax))) - (defun logxor (&rest integers) - (declare (dynamic-extent integers)) - (if (null integers) - 0 - (reduce #'logxor%2op integers))) + (numargs-case + (1 (x) x) + (2 (x y) + (number-double-dispatch (x y) + ((fixnum fixnum) + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) x) + (:compile-form (:result-mode :ebx) y) + (:xorl :ebx :eax))))) + (t (&rest integers) + (declare (dynamic-extent integers)) + (if (null integers) + 0 + (reduce #'logxor integers))))) (defun lognot (integer) (check-type integer fixnum) @@ -1294,20 +1296,363 @@ (:xorl #.(cl:- #xffffffff movitz::+movitz-fixnum-zmask+) :eax))) (defun ldb%byte (size position integer) - (check-type size fixnum) - (check-type position fixnum) - (logand (ash integer (- position)) - (svref #(#x0 #x1 #x3 #x7 - #xf #x1f #x3f #x7f - #xff #x1ff #x3ff #x7ff - #xfff #x1fff #x3fff #x7fff - #xffff #x1ffff #x3ffff #x7ffff - #xfffff #x1fffff #x3fffff #x7fffff - #xffffff #x1ffffff #x3ffffff #x7ffffff - #xfffffff) - size))) + "This is LDB with explicit byte-size and position parameters." + (check-type size positive-fixnum) + (check-type position positive-fixnum) + (etypecase integer + (fixnum + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ecx) integer position) + (:cmpl ,(* (1- movitz:+movitz-fixnum-bits+) movitz:+movitz-fixnum-factor+) + :ecx) + (:ja '(:sub-program (outside-fixnum) + (:break) + (:addl #x80000000 :eax) ; sign into carry + (:sbbl :ecx :ecx) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax) + (:jmp 'mask-fixnum))) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:std) ; <================= STD + (:sarl :cl :eax) ; shift.. + (:andl ,(logxor #xffffffff movitz:+movitz-fixnum-zmask+) :eax) + (:cld) ; =================> CLD + mask-fixnum + (:compile-form (:result-mode :ecx) size) + (:cmpl ,(* (1- movitz:+movitz-fixnum-bits+) movitz:+movitz-fixnum-factor+) + :ecx) + (:jna 'fixnum-result) + (:testl :eax :eax) + (:jns 'fixnum-done) + ;; We need to generate a bignum.. + ;; ..filling in 1-bits since the integer is negative. + (:pushl :eax) ; This will become the LSB bigit. + retry-ones-expanded-bignum + (:declare-label-set retry-jumper-ones-expanded-bignum (retry-ones-expanded-bignum)) + ;; Calculate word-size from bytespec-size. + (:compile-form (:result-mode :ecx) size) + (:subl ,movitz:+movitz-fixnum-factor+ :ecx) ; Subtract 1 + (:shrl ,(+ 5 movitz:+movitz-fixnum-shift+) :ecx) ; Divide by 32 + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ; Add 1 for index->size.. + ,(* 2 movitz:+movitz-fixnum-factor+)) ; ..and 1 for header. + :eax) + (:locally (:movl :esp (:edi (:edi-offset atomically-esp)))) + (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp) + 'retry-jumper-ones-expanded-bignum) + (:edi (:edi-offset atomically-status)))) + (:call-global-constant get-cons-pointer) + (:shll 16 :ecx) + (:addl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0)) :ecx) ; add 1 for index->size + (:movl :ecx (:eax ,movitz:+other-type-offset+)) + (:shrl 16 :ecx) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) + ,(* 1 movitz:+movitz-fixnum-factor+)) ; add 1 for header. + :ecx) + (:call-global-constant cons-commit) + (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) + (:edi (:edi-offset atomically-status)))) + ;; Have fresh bignum in EAX, now fill it with ones. + (:xorl :ecx :ecx) ; counter + fill-ones-loop + (:movl #xffffffff + (:eax (:ecx 4) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + (:addl 1 :ecx) + (:cmpw :cx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length))) + (:jne 'fill-ones-loop) + + (:popl :ecx) ; The LSB bigit. + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:movl :ecx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + (:movl :eax :ebx) + ;; Compute MSB bigit mask in EDX + (:compile-form (:result-mode :ecx) size) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:std) ; <================= STD + (:xorl :edx :edx) + (:andl 31 :ecx) + (:jz 'fixnum-mask-ok) + (:addl 1 :edx) + (:shll :cl :edx) + fixnum-mask-ok + (:subl 1 :edx) + (:movzxw (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length)) + :ecx) + (:andl :edx ; And EDX with the MSB bigit. + (:ebx (:ecx 4) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))) + (:movl :edi :edx) + (:movl :edi :eax) + (:cld) ; =================> CLD + (:movl :ebx :eax) + (:jmp 'fixnum-done) + + fixnum-result + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:movl ,movitz:+movitz-fixnum-factor+ :edx) ; generate fixnum mask in EDX + (:shll :cl :edx) + (:subl ,movitz:+movitz-fixnum-factor+ :edx) + (:andl :edx :eax) + (:jmp 'fixnum-done) + fixnum-done + ))) + (do-it))) + (positive-bignum + (cond + ((<= size 32) + ;; The result is likely to be a fixnum (or at least an u32), due to byte-size. + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :ebx) integer) + (:compile-form (:result-mode :eax) position) + (:movl :eax :ecx) ; compute bigit-number in ecx + (:sarl ,(+ 5 movitz:+movitz-fixnum-shift+) :ecx) + (:addl 1 :ecx) + (:cmpl #x10000 :ecx) + (:jae 'position-outside-integer) + (:cmpw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:jc '(:sub-program (position-outside-integer) + (:movsxb (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::sign)) :ecx) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax) + (:jmp 'done-u32))) + (:std) + (:movl (:ebx (:ecx 4) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + :eax) + (:movl 0 :edx) ; If position was in last bigit.. (don't touch EFLAGS) + (:je 'no-top-bigit) ; ..we must zero-extend rather than read top bigit. + (:movl (:ebx (:ecx 4) ,(+ 0 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + :edx) ; Read top bigit into EDX + no-top-bigit + (:testl #xff00 (:ebx ,movitz:+other-type-offset+)) + (:jnz '(:sub-program (negative-bignum) + ;; We must negate the bigits.. + (:break) + )) + edx-eax-ok + ;; EDX:EAX now holds the number that must be shifted and masked. + (:compile-form (:result-mode :ecx) position) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:shrdl :cl :edx :eax) ; Shifted value into EAX + (:compile-form (:result-mode :ecx) size) + (:xorl :edx :edx) ; Generate a mask in EDX + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:testl 31 :ecx) + (:jz 'mask-ok-u32) + (:addl 1 :edx) + (:shll :cl :edx) + mask-ok-u32 + (:subl 1 :edx) + (:andl :edx :eax) + (:movl :eax :ecx) ; For boxing.. + (:movl :edi :eax) + (:movl :edi :edx) + (:cld) + ;; See if we can return same bignum.. + (:cmpl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0)) + (:ebx ,movitz:+other-type-offset+)) + (:jne 'cant-return-same) + (:cmpl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + (:jne 'cant-return-same) + (:movl :ebx :eax) + (:jmp 'done-u32) + cant-return-same + (:call-global-constant box-u32-ecx) + done-u32 + ))) + (do-it))) + (t (macrolet + ((do-it () + `(let () + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :ebx) integer) + (:compile-form (:result-mode :ecx) position) + (:shrl ,(+ 5 movitz:+movitz-fixnum-shift+) :ecx) ; compute bigit-number in ecx + (:cmpl #x10000 :ecx) + (:jnc 'position-outside-integer) + (:cmpw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:jbe '(:sub-program (position-outside-integer) + (:movsxb (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::sign)) :ecx) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax) + (:jmp 'done-u32))) + + (:compile-two-forms (:edx :ecx) position size) + (:movl :ecx :eax) ; keep size/fixnum in EAX. + (:addl :edx :ecx) + (:into) ; just to make sure + (:shrl ,(+ 5 movitz:+movitz-fixnum-shift+) :ecx) ; compute msb bigit index in ecx + (:addl 1 :ecx) + (:cmpw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (je '(:sub-program (equal-size-maybe-return-same) + (:testl :edx :edx) ; Can only return same if (zerop position). + (:jnz 'adjust-size) + (:movl :eax :ecx) ; size/fixnum + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:andl 31 :ecx) + (:jz 'yes-return-same) + (:std) ; <================ + ;; we know EDX=0, now generate mask in EDX + (:addl 1 :edx) + (:shll :cl :edx) + (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) + :ecx) + (:cmpl :edx (:ebx (:ecx 4) + ,(+ -4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))) + (:movl 0 :edx) ; Safe value, and correct if we need to go to adjust-size. + (:cld) ; =================> + (:jnc 'adjust-size) ; nope, we have to generate a new bignum. + yes-return-same + (:movl :ebx :eax) ; yep, we can return same bignum. + (:jmp 'ldb-done))) + (:jnc 'size-ok) + ;; We now know that (+ size position) is beyond the size of the bignum. + ;; So, if (zerop position), we can return the bignum as our result. + (:testl :edx :edx) + (:jz '(:sub-program () + (:movl :ebx :eax) ; return the source bignum. + (:jmp 'ldb-done))) + adjust-size + ;; The bytespec is (partially) outside source-integer, so we make the + ;; size smaller before proceeding. new-size = (- source-int-length position) + (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) + :ecx) ; length of source-integer + (:shll ,(+ 5 movitz:+movitz-fixnum-shift+) :ecx) ; fixnum bit-position + (:xorl :eax :eax) ; In case the new size is zero. + (:subl :edx :ecx) ; subtract position + (:js '(:sub-program (should-not-happen) + ;; new size should never be negative. + (:break))) + (:jz 'ldb-done) ; New size was zero, so the result of ldb is zero. + (:movl :ecx :eax) ; New size into EAX. + size-ok + retry + (:declare-label-set retry-jumper (retry)) + (:locally (:movl :esp (:edi (:edi-offset atomically-esp)))) + (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp) + 'retry-jumper) + (:edi (:edi-offset atomically-status)))) + ;; (new) Size is in EAX. + (:pushl :eax) ; Save for later + (:subl ,movitz:+movitz-fixnum-factor+ :eax) + (:andl ,(logxor #xffffffff + (mask-field (byte (+ 5 movitz:+movitz-fixnum-shift+) 0) -1)) + :eax) + (:shrl 5 :eax) ; Divide (size-1) by 32 to get number of bigits-1 + ;; Now add 1 for index->size, 1 for header, and 1 for tmp storage before shift. + (:addl ,(* 3 movitz:+movitz-fixnum-factor+) :eax) + (:pushl :eax) + (:call-global-constant get-cons-pointer) + ;; (:store-lexical (:lexical-binding r) :eax :type t) + (:popl :ecx) + (:subl ,(* 2 movitz:+movitz-fixnum-factor+) :ecx) ; for tmp storage and header. + (:shll ,(- 16 movitz:+movitz-fixnum-shift+) :ecx) + (:orl ,(movitz:tag :bignum 0) :ecx) + (:movl :ecx (:eax ,movitz:+other-type-offset+)) + (:compile-form (:result-mode :ebx) integer) + + (:xchgl :eax :ebx) + ;; now: EAX = old integer, EBX = new result bignum + + ;; Edge case: When size(old)=size(new), the tail-tmp must be zero. + ;; We check here, setting the tail-tmp to a mask for and-ing below. + (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) + :ecx) ; length of source-integer + ;; Initialize tail-tmp to #xffffffff, meaning copy from source-integer. + (:movl #xffffffff + (:ebx (:ecx 4) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + (:cmpw :cx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:jc '(:sub-program (result-too-big-shouldnt-happen) + (:break))) + (:jne 'tail-tmp-ok) + ;; Sizes was equal, so set tail-tmp to zero. + (:movl 0 (:ebx (:ecx 4) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + tail-tmp-ok + ;; Now copy the relevant part of the integer + (:std) + (:compile-form (:result-mode :ecx) position) + (:sarl ,(+ 5 movitz:+movitz-fixnum-shift+) :ecx) ; compute bigit-number in ecx + ;; We can use primitive pointers because we're both inside atomically and std. + (:leal (:eax (:ecx 4) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) + :eax) ; Use EAX as primitive pointer into source + (:xorl :ecx :ecx) ; counter + copy-integer + (:movl (:eax) :edx) + (:addl 4 :eax) + (:movl :edx (:ebx (:ecx 4) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + (:addl 1 :ecx) + (:cmpw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:jne 'copy-integer) + ;; Copy one more than the length, namely the tmp at the end. + ;; Tail-tmp was initialized to a bit-mask above. + (:movl (:eax) :edx) + (:andl :edx (:ebx (:ecx 4) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + ;; Copy done, now shift + (:compile-form (:result-mode :ecx) position) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:andl 31 :ecx) + (:jz 'shift-done) ; if (zerop (mod position 32)), no shift needed. + (:xorl :edx :edx) ; counter + shift-loop + (:movl (:ebx (:edx 4) ,(+ 4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + :eax) ; Next bigit into eax + (:shrdl :cl :eax ; Now shift bigit, with msbs from eax. + (:ebx (:edx 4) ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + (:addl 1 :edx) + (:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:jne 'shift-loop) + shift-done + ;; Now we must mask MSB bigit. + (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) + :edx) + (:popl :ecx) ; (new) bytespec size + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:andl 31 :ecx) + (:jz 'mask-done) + (:movl 1 :eax) ; Generate mask in EAX + (:shll :cl :eax) + (:subl 1 :eax) + (:andl :eax + (:ebx (:edx 4) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))) + mask-done + (:movl :edi :edx) ; safe EDX + (:movl :edi :eax) ; safe EAX + (:cld) + ;; Now we must zero-truncate the result bignum in EBX. + (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) + :ecx) + zero-truncate-loop + (:cmpl 0 (:ebx (:ecx 4) + ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))) + (:jne 'zero-truncate-done) + (:subl 1 :ecx) + (:jnz 'zero-truncate-loop) + ;; Zero bigits means the entire result collapsed to zero. + (:xorl :eax :eax) + (:jmp 'return-fixnum) ; don't commit the bignum allocation. + zero-truncate-done + (:cmpl 1 :ecx) ; If result size is 1, the result might have.. + (:jne 'complete-bignum-allocation) ; ..collapsed to a fixnum. + (:cmpl ,movitz:+movitz-most-positive-fixnum+ + (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + (:ja 'complete-bignum-allocation) + (:movl (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) + :ecx) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax) + (:jmp 'return-fixnum) + complete-bignum-allocation + (:movw :cx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:movl :ebx :eax) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+) + :ecx) + (:call-global-constant cons-commit) + return-fixnum + (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) + (:edi (:edi-offset atomically-status)))) + ldb-done)))) + (do-it))))))) + (define-compiler-macro ldb%byte (&whole form &environment env size position integer) + "This is LDB with explicit byte-size and position parameters." (cond ((and (movitz:movitz-constantp size env) (movitz:movitz-constantp position env) @@ -1414,7 +1759,6 @@ (defun dpb (newbyte bytespec integer) (logior (mask-field bytespec (ash newbyte (byte-position bytespec))) (logandc2 integer (mask-field bytespec -1)))) - (defun mask-field (bytespec integer) (ash (ldb bytespec integer) (byte-position bytespec))) From ffjeld at common-lisp.net Tue Jun 8 22:02:48 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 08 Jun 2004 15:02:48 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3019 Modified Files: basic-macros.lisp Log Message: Slightly improved eql. Date: Tue Jun 8 15:02:47 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.20 movitz/losp/muerte/basic-macros.lisp:1.21 --- movitz/losp/muerte/basic-macros.lisp:1.20 Tue Jun 8 13:06:26 2004 +++ movitz/losp/muerte/basic-macros.lisp Tue Jun 8 15:02:47 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.20 2004/06/08 20:06:26 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.21 2004/06/08 22:02:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -420,8 +420,22 @@ (:compile-two-forms (:eax :ebx) ,x ,y) (:cmpl :eax :ebx))))) -(define-compiler-macro eql (x y) - `(eq ,x ,y)) +(define-compiler-macro eql (&whole form x y &environment env) + (cond + ((and (movitz:movitz-constantp x env) + (movitz:movitz-constantp y env)) + (eql (movitz:movitz-eval x env) + (movitz:movitz-eval y env))) + ((movitz:movitz-constantp y env) + `(eql ,y ,x)) + ((movitz:movitz-constantp x env) + (let ((x (movitz:movitz-eval x env))) + (typecase x + (number + `(= ,x ,y)) + (t `(eq ,x ,y))))) + (t form))) + (define-compiler-macro values (&rest sub-forms) `(inline-values , at sub-forms)) From ffjeld at common-lisp.net Tue Jun 8 22:02:52 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 08 Jun 2004 15:02:52 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/equalp.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3192 Modified Files: equalp.lisp Log Message: Slightly improved eql. Date: Tue Jun 8 15:02:52 2004 Author: ffjeld Index: movitz/losp/muerte/equalp.lisp diff -u movitz/losp/muerte/equalp.lisp:1.3 movitz/losp/muerte/equalp.lisp:1.4 --- movitz/losp/muerte/equalp.lisp:1.3 Mon Mar 29 06:56:26 2004 +++ movitz/losp/muerte/equalp.lisp Tue Jun 8 15:02:52 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 13 17:09:08 2001 ;;;; -;;;; $Id: equalp.lisp,v 1.3 2004/03/29 14:56:26 ffjeld Exp $ +;;;; $Id: equalp.lisp,v 1.4 2004/06/08 22:02:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -22,7 +22,9 @@ (in-package muerte) (defun eql (x y) - (eql x y)) + (if (typep x 'bignum) + (and (typep y 'bignum) (= x y)) + (eq x y))) (defun equal (x y) (typecase x From ffjeld at common-lisp.net Tue Jun 8 23:30:25 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 08 Jun 2004 16:30:25 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9539 Modified Files: integers.lisp Log Message: Fixed the number-comparing primitives to deal with bignums. So =, >, < etc. should now work. Date: Tue Jun 8 16:30:24 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.26 movitz/losp/muerte/integers.lisp:1.27 --- movitz/losp/muerte/integers.lisp:1.26 Tue Jun 8 13:11:13 2004 +++ movitz/losp/muerte/integers.lisp Tue Jun 8 16:30:24 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.26 2004/06/08 20:11:13 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.27 2004/06/08 23:30:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -280,30 +280,133 @@ ;;; Comparison (define-primitive-function fast-compare-two-reals (n1 n2) - "Check that n1 and n2 are fixnums, and compare them." - (with-inline-assembly (:returns :nothing) ; unspecified - (:testb #.movitz::+movitz-fixnum-zmask+ :al) - (:jnz '(:sub-program () - (:int 107) - (:jmp (:pc+ -4)))) - (:testb #.movitz::+movitz-fixnum-zmask+ :bl) - (:jnz '(:sub-program () - (:movl :ebx :eax) - (:int 107) - (:jmp (:pc+ -4)))) - (:cmpl :ebx :eax) - (:ret))) + "Compare two numbers (i.e. set EFLAGS accordingly)." + (macrolet + ((do-it () + `(with-inline-assembly (:returns :nothing) ; unspecified + (:testb ,movitz::+movitz-fixnum-zmask+ :al) + (:jnz 'n1-not-fixnum) + (:testb ,movitz::+movitz-fixnum-zmask+ :bl) + (:jnz 'n2-not-fixnum-but-n1-is) + (:cmpl :ebx :eax) ; both were fixnum + (:ret) + n1-not-fixnum ; but we don't know about n2 + (:testb ,movitz::+movitz-fixnum-zmask+ :bl) + (:jnz 'neither-is-fixnum) + ;; n2 is fixnum + (:locally (:jmp (:edi (:edi-offset fast-compare-real-fixnum)))) + n2-not-fixnum-but-n1-is + (:locally (:jmp (:edi (:edi-offset fast-compare-fixnum-real)))) + neither-is-fixnum + ;; Check that both numbers are bignums, and compare them. + (:leal (:eax ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jnz '(:sub-program (n1-not-bignum) + (:int 107))) + (:movl (:eax ,movitz:+other-type-offset+) :ecx) + (:cmpb ,(movitz:tag :bignum) :cl) + (:jne 'n1-not-bignum) + + (:cmpl :eax :ebx) ; If they are EQ, they are certainly = + (:je '(:sub-program (n1-and-n2-are-eq) + (:ret))) + + (:leal (:ebx ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jnz '(:sub-program (n2-not-bignum) + (:int 107))) + (:movl (:ebx ,movitz:+other-type-offset+) :ecx) + (:cmpb ,(movitz:tag :bignum) :cl) + (:jne 'n2-not-bignum) + + (:cmpb :ch (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::sign))) + (:jne '(:sub-program (different-signs) + ;; Comparing the sign-bytes sets up EFLAGS correctly! + (:ret))) + (:testl #xff00 :ecx) + (:jnz 'compare-negatives) + ;; Both n1 and n2 are positive bignums. + + (:shrl 16 :ecx) + (:cmpw :cx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length))) + (:jne '(:sub-program (positive-different-sizes) + (:ret))) + + ;; Both n1 and n2 are positive bignums of the same size, namely ECX. + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) + :edx) ; counter + positive-compare-loop + (:subl ,movitz:+movitz-fixnum-factor+ :edx) + (:jz 'positive-compare-lsb) + (:movl (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) + :ecx) + (:cmpl :ecx + (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + (:je 'positive-compare-loop) + (:ret) + positive-compare-lsb ; it's down to the LSB bigits. + (:movl (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) + :ecx) + (:cmpl :ecx + (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + (:ret) + + compare-negatives + ;; Moth n1 and n2 are negative bignums. + + (:shrl 16 :ecx) + (:cmpw (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length)) :cx) + (:jne '(:sub-program (negative-different-sizes) + (:ret))) + + ;; Both n1 and n2 are negative bignums of the same size, namely ECX. + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) + :edx) ; counter + negative-compare-loop + (:subl ,movitz:+movitz-fixnum-factor+ :edx) + (:jz 'negative-compare-lsb) + (:movl (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) + :ecx) + (:cmpl :ecx + (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + (:je 'negative-compare-loop) + (:ret) + negative-compare-lsb ; it's down to the LSB bigits. + (:movl (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) + :ecx) + (:cmpl :ecx + (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + (:ret)))) + (do-it))) (define-primitive-function fast-compare-fixnum-real (n1 n2) "Compare (known) fixnum with real ." - (with-inline-assembly (:returns :nothing) ; unspecified - (:testb #.movitz::+movitz-fixnum-zmask+ :bl) - (:jnz '(:sub-program (not-integer) - (:movl :ebx :eax) - (:int 107) - (:jmp 'not-integer))) - (:cmpl :ebx :eax) - (:ret))) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :nothing) ; unspecified + (:testb ,movitz::+movitz-fixnum-zmask+ :bl) + (:jnz 'n2-not-fixnum) + (:cmpl :ebx :eax) + (:ret) + n2-not-fixnum + (:leal (:ebx ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jnz '(:sub-program (not-integer) + (:int 107) + (:jmp 'not-integer))) + (:movl (:ebx ,movitz:+other-type-offset+) :ecx) + (:cmpw ,(movitz:tag :bignum 0) :cx) + (:jne 'not-plusbignum) + ;; compare eax with something bigger + (:cmpl #x10000000 :edi) + (:ret) + not-plusbignum + (:cmpw ,(movitz:tag :bignum #xff) :cx) + (:jne 'not-integer) + ;; compare ebx with something bigger + (:cmpl #x-10000000 :edi) + (:ret)))) + (do-it))) (define-primitive-function fast-compare-real-fixnum (n1 n2) "Compare real with fixnum ." @@ -529,7 +632,6 @@ (defun = (first-number &rest numbers) (declare (dynamic-extent numbers)) - (check-type first-number fixnum) (dolist (n numbers t) (unless (= first-number n) (return nil)))) From ffjeld at common-lisp.net Wed Jun 9 01:16:42 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 08 Jun 2004 18:16:42 -0700 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv1134 Modified Files: image.lisp Log Message: New and improved EQL. Now it's simply a primitive-function. Date: Tue Jun 8 18:16:42 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.36 movitz/image.lisp:1.37 --- movitz/image.lisp:1.36 Sat Jun 5 20:01:19 2004 +++ movitz/image.lisp Tue Jun 8 18:16:42 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.36 2004/06/06 03:01:19 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.37 2004/06/09 01:16:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -236,14 +236,6 @@ :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector :binary-tag :primitive-function) - (malloc - :binary-type code-vector-word - :map-binary-write 'movitz-intern-code-vector - :map-binary-read-delayed 'movitz-word-code-vector - :binary-tag :primitive-function) - (malloc-buffer - :binary-type lu32 - :initform 0) (fast-cdr-car :binary-type code-vector-word :initform nil @@ -280,6 +272,12 @@ :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector :binary-tag :primitive-function) + (fast-eql + :binary-type code-vector-word + :initform nil + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) (trampoline-cl-dispatch-1or2 :binary-type code-vector-word :initform nil @@ -290,12 +288,20 @@ :binary-type word :binary-tag :global-function :map-binary-read-delayed 'movitz-word - :map-binary-write 'movitz-intern) + :map-binary-write 'movitz-intern) (num-values :binary-type lu32 :initform 0) (values :binary-type #.(* 4 +movitz-multiple-values-limit+)) + (malloc + :binary-type code-vector-word + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) + (malloc-buffer + :binary-type lu32 + :initform 0) (default-interrupt-trampoline :map-binary-write 'movitz-intern-code-vector :binary-tag :primitive-function From ffjeld at common-lisp.net Wed Jun 9 01:16:47 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 08 Jun 2004 18:16:47 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1203 Modified Files: basic-macros.lisp Log Message: New and improved EQL. Now it's simply a primitive-function. Date: Tue Jun 8 18:16:47 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.21 movitz/losp/muerte/basic-macros.lisp:1.22 --- movitz/losp/muerte/basic-macros.lisp:1.21 Tue Jun 8 15:02:47 2004 +++ movitz/losp/muerte/basic-macros.lisp Tue Jun 8 18:16:47 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.21 2004/06/08 22:02:47 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.22 2004/06/09 01:16:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -428,14 +428,13 @@ (movitz:movitz-eval y env))) ((movitz:movitz-constantp y env) `(eql ,y ,x)) - ((movitz:movitz-constantp x env) - (let ((x (movitz:movitz-eval x env))) - (typecase x - (number - `(= ,x ,y)) - (t `(eq ,x ,y))))) - (t form))) - + ((and (movitz:movitz-constantp x env) + (not (typep (movitz:movitz-eval x env) + '(and integer (not fixnum))))) + `(eq ',x ,y)) + (t `(with-inline-assembly (:returns :boolean-zf=1) + (:compile-two-forms (:eax :ebx) ,x ,y) + (:call-global-constant fast-eql))))) (define-compiler-macro values (&rest sub-forms) `(inline-values , at sub-forms)) From ffjeld at common-lisp.net Wed Jun 9 01:16:52 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 08 Jun 2004 18:16:52 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/equalp.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1249 Modified Files: equalp.lisp Log Message: New and improved EQL. Now it's simply a primitive-function. Date: Tue Jun 8 18:16:52 2004 Author: ffjeld Index: movitz/losp/muerte/equalp.lisp diff -u movitz/losp/muerte/equalp.lisp:1.4 movitz/losp/muerte/equalp.lisp:1.5 --- movitz/losp/muerte/equalp.lisp:1.4 Tue Jun 8 15:02:52 2004 +++ movitz/losp/muerte/equalp.lisp Tue Jun 8 18:16:52 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 13 17:09:08 2001 ;;;; -;;;; $Id: equalp.lisp,v 1.4 2004/06/08 22:02:52 ffjeld Exp $ +;;;; $Id: equalp.lisp,v 1.5 2004/06/09 01:16:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -22,9 +22,7 @@ (in-package muerte) (defun eql (x y) - (if (typep x 'bignum) - (and (typep y 'bignum) (= x y)) - (eq x y))) + (eql x y)) (defun equal (x y) (typecase x From ffjeld at common-lisp.net Wed Jun 9 01:16:57 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 08 Jun 2004 18:16:57 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1277 Modified Files: integers.lisp Log Message: New and improved EQL. Now it's simply a primitive-function. Date: Tue Jun 8 18:16:56 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.27 movitz/losp/muerte/integers.lisp:1.28 --- movitz/losp/muerte/integers.lisp:1.27 Tue Jun 8 16:30:24 2004 +++ movitz/losp/muerte/integers.lisp Tue Jun 8 18:16:56 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.27 2004/06/08 23:30:24 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.28 2004/06/09 01:16:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -376,6 +376,41 @@ :ecx) (:cmpl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + (:ret)))) + (do-it))) + +(define-primitive-function fast-eql (x y) + "Compare EAX and EBX under EQL, result in ZF. +Preserve EAX and EBX." + (macrolet + ((do-it () + `(with-inline-assembly (:returns :nothing) ; unspecified + (:cmpl :eax :ebx) ; EQ? + (:je 'done) + (:leal (:eax ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jne 'done) + (:leal (:ebx ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jne 'done) + (:movl (:eax ,movitz:+other-type-offset+) :ecx) + (:cmpb ,(movitz:tag :bignum) :cl) + (:jne 'done) + (:cmpl :ecx (:ebx ,movitz:+other-type-offset+)) + (:jne 'done) + ;; Ok.. we have two bignums of identical sign and size. + (:shrl 16 :ecx) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+) + :edx) ; counter + compare-loop + (:subl ,movitz:+movitz-fixnum-factor+ :edx) + (:jz 'done) + (:movl (:eax :edx ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + :ecx) + (:cmpl :ecx + (:ebx :edx ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))) + (:je 'compare-loop) + done (:ret)))) (do-it))) From ffjeld at common-lisp.net Wed Jun 9 17:18:36 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 10:18:36 -0700 Subject: [movitz-cvs] CVS update: movitz/compiler-types.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv28406 Modified Files: compiler-types.lisp Log Message: Improved the type codec wrt. to bignums/fixnums, in particular. Date: Wed Jun 9 10:18:36 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.13 movitz/compiler-types.lisp:1.14 --- movitz/compiler-types.lisp:1.13 Mon Jun 7 15:09:24 2004 +++ movitz/compiler-types.lisp Wed Jun 9 10:18:36 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.13 2004/06/07 22:09:24 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.14 2004/06/09 17:18:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -224,8 +224,10 @@ (typep x 'movitz-symbol)) ((vector array) (typep x 'movitz-vector)) - (integer - (typep x 'movitz-fixnum)))) + (fixnum + (typep x 'movitz-fixnum)) + (bignum + (typep x 'movitz-bignum)))) (defun type-code (first-type &rest types) "Find the code (a bitmap) for (or , at types)." @@ -317,16 +319,21 @@ (= x (logand x code)))) (defun encoded-typep (errorp undecided-value x code integer-range members include complement) + "Is the movitz-object x included in the encoded-type?" (let ((x (or (= -1 code) (and (member x members :test #'movitz-eql) t) (cond ((typep x 'movitz-nil) (type-code-p 'symbol code)) - ((basic-typep x 'integer) + ((basic-typep x 'fixnum) (or (type-code-p 'integer code) (and integer-range (numscope-memberp integer-range (movitz-fixnum-value x))))) - (t (dolist (bt '(symbol character function cons hash-table) + ((basic-typep x 'bignum) + (or (type-code-p 'integer code) + (and integer-range + (numscope-memberp integer-range (movitz-bignum-value x))))) + (t (dolist (bt '(symbol character function cons hash-table vector) (error "Cant decide typep for ~S." x)) (when (basic-typep x bt) (return (type-code-p bt code)))))) @@ -436,7 +443,10 @@ ((atom type-specifier) (case type-specifier (fixnum - (type-values 'integer)) + (type-specifier-encode `(signed-byte ,+movitz-fixnum-bits+))) + (bignum + (type-specifier-encode `(or (integer * ,(1- +movitz-most-negative-fixnum+)) + (integer ,(1+ +movitz-most-positive-fixnum+) *)))) ((t nil cons symbol keyword function array vector integer hash-table character) (type-values type-specifier)) (null From ffjeld at common-lisp.net Wed Jun 9 17:19:24 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 10:19:24 -0700 Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv31584 Modified Files: storage-types.lisp Log Message: Added update-movitz-object for bignums. Date: Wed Jun 9 10:19:24 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.18 movitz/storage-types.lisp:1.19 --- movitz/storage-types.lisp:1.18 Mon May 24 07:58:22 2004 +++ movitz/storage-types.lisp Wed Jun 9 10:19:24 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.18 2004/05/24 14:58:22 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.19 2004/06/09 17:19:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -157,7 +157,7 @@ (defmethod update-movitz-object ((obj movitz-heap-object) lisp-obj) (declare (ignore lisp-obj)) - (warn "Don't know how to update ~W." obj)) + (break "Don't know how to update ~W." obj)) (defmethod update-movitz-object ((obj movitz-immediate-object) lisp-obj) (declare (ignore lisp-obj)) @@ -1330,3 +1330,7 @@ (defmethod sizeof ((obj movitz-bignum)) (+ (sizeof 'movitz-bignum) (* 4 (ceiling (integer-length (abs (movitz-bignum-value obj))) 32)))) + +(defmethod update-movitz-object ((object movitz-bignum) lisp-object) + (assert (= (movitz-bignum-value object) lisp-object)) + object) From ffjeld at common-lisp.net Wed Jun 9 17:21:01 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 10:21:01 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2296 Modified Files: symbols.lisp Log Message: Somewhat improved makunbound. Date: Wed Jun 9 10:21:01 2004 Author: ffjeld Index: movitz/losp/muerte/symbols.lisp diff -u movitz/losp/muerte/symbols.lisp:1.12 movitz/losp/muerte/symbols.lisp:1.13 --- movitz/losp/muerte/symbols.lisp:1.12 Wed Apr 21 07:00:15 2004 +++ movitz/losp/muerte/symbols.lisp Wed Jun 9 10:21:01 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 4 23:55:41 2001 ;;;; -;;;; $Id: symbols.lisp,v 1.12 2004/04/21 14:00:15 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.13 2004/06/09 17:21:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -130,7 +130,8 @@ (defun makunbound (symbol) (setf (symbol-value symbol) - 'unbound)) + (load-global-constant unbound-value)) + symbol) (defun fboundp (symbol) (etypecase symbol From ffjeld at common-lisp.net Wed Jun 9 17:21:47 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 10:21:47 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3042 Modified Files: typep.lisp Log Message: Fixed buglet in typep compiler-macro. Date: Wed Jun 9 10:21:47 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.13 movitz/losp/muerte/typep.lisp:1.14 --- movitz/losp/muerte/typep.lisp:1.13 Wed Jun 2 16:48:45 2004 +++ movitz/losp/muerte/typep.lisp Wed Jun 9 10:21:47 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.13 2004/06/02 23:48:45 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.14 2004/06/09 17:21:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -371,7 +371,7 @@ `(let ((typep-object ,object)) (,(car type) ,@(loop for subtype in (cdr type) - collect `(typep ,object ',subtype))))) + collect `(typep typep-object ',subtype))))) (t (warn "compiling typep ~A" type))))))) form))))) @@ -403,7 +403,8 @@ (let ((fname (intern (format nil "~A-~A" 'deftype name)))) `(progn (eval-when (:compile-toplevel) - (setf (gethash ',name *compiler-derived-typespecs*) + (setf (gethash (translate-program ',name :cl :muerte.cl) + *compiler-derived-typespecs*) (lambda ,lambda , at body)) (setf (gethash (intern ,(symbol-name name)) *derived-typespecs*) From ffjeld at common-lisp.net Wed Jun 9 17:22:51 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 10:22:51 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3626 Modified Files: more-macros.lisp Log Message: Ensure some well-known unimplemented operators produce appropriate compile-time errors. Date: Wed Jun 9 10:22:51 2004 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.8 movitz/losp/muerte/more-macros.lisp:1.9 --- movitz/losp/muerte/more-macros.lisp:1.8 Fri Jun 4 06:32:16 2004 +++ movitz/losp/muerte/more-macros.lisp Wed Jun 9 10:22:51 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.8 2004/06/04 13:32:16 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.9 2004/06/09 17:22:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -311,3 +311,13 @@ (let ((,object-var ,instance-form)) , at declarations-and-forms)))) + +;;; Some macros that aren't implemented, and we want to give compiler errors. + +(defmacro define-unimplemented-macro (name) + `(defmacro ,name (&rest args) + (declare (ignore args)) + (error ,(format nil "Macro ~A is not implemented yet." name)))) + +(define-unimplemented-macro with-open-file) +(define-unimplemented-macro restart-case) From ffjeld at common-lisp.net Wed Jun 9 17:23:16 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 10:23:16 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4049 Modified Files: basic-macros.lisp Log Message: Slightly improved load-global-constant. Date: Wed Jun 9 10:23:16 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.22 movitz/losp/muerte/basic-macros.lisp:1.23 --- movitz/losp/muerte/basic-macros.lisp:1.22 Tue Jun 8 18:16:47 2004 +++ movitz/losp/muerte/basic-macros.lisp Wed Jun 9 10:23:16 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.22 2004/06/09 01:16:47 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.23 2004/06/09 17:23:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1005,10 +1005,10 @@ (defmacro load-global-constant (name &key thread-local) (if thread-local - `(with-inline-assembly (:returns :eax) - (:locally (:movl (:edi (:edi-offset ,name)) :eax))) - `(with-inline-assembly (:returns :eax) - (:globally (:movl (:edi (:edi-offset ,name)) :eax))))) + `(with-inline-assembly (:returns :register) + (:locally (:movl (:edi (:edi-offset ,name)) (:result-register)))) + `(with-inline-assembly (:returns :register) + (:globally (:movl (:edi (:edi-offset ,name)) (:result-register)))))) (defmacro load-global-constant-u32 (name &key thread-local) (if thread-local From ffjeld at common-lisp.net Wed Jun 9 17:25:04 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 10:25:04 -0700 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv6395 Modified Files: image.lisp Log Message: Minor edits. Date: Wed Jun 9 10:25:04 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.37 movitz/image.lisp:1.38 --- movitz/image.lisp:1.37 Tue Jun 8 18:16:42 2004 +++ movitz/image.lisp Wed Jun 9 10:25:03 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.37 2004/06/09 01:16:42 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.38 2004/06/09 17:25:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -419,7 +419,7 @@ :initform nil :map-binary-write 'movitz-read-and-intern :map-binary-read-delayed 'movitz-word) - (align-segment-descriptors :binary-type 4) + ;; (align-segment-descriptors :binary-type 4) (segment-descriptor-table :binary-type :label) (segment-descriptor-0 :binary-type segment-descriptor @@ -543,14 +543,14 @@ (cons-pointer :accessor image-cons-pointer) (read-map-hash - :initform (make-hash-table :test #'eq) ; lisp object => movitz object + :initform (make-hash-table :test #'eql) ; lisp object => movitz object :reader image-read-map-hash) (inverse-read-map-hash - :initform (make-hash-table :test #'eq) ; lisp object => movitz object + :initform (make-hash-table :test #'eql) ; lisp object => movitz object :reader image-inverse-read-map-hash) (oblist :reader image-oblist - :initform (make-hash-table :test #'eq)) + :initform (make-hash-table :test #'eql)) (global-environment :initform (make-global-movitz-environment) :reader image-global-environment) From ffjeld at common-lisp.net Wed Jun 9 17:26:01 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 10:26:01 -0700 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv7611 Modified Files: compiler.lisp Log Message: Quite a bit of cruft regarding register allocation etc. Still more work to do here, but I don't have time for it right now.. Date: Wed Jun 9 10:26:00 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.63 movitz/compiler.lisp:1.64 --- movitz/compiler.lisp:1.63 Tue Jun 8 01:14:15 2004 +++ movitz/compiler.lisp Wed Jun 9 10:26:00 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.63 2004/06/08 08:14:15 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.64 2004/06/09 17:26:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -471,6 +471,9 @@ binding-usage)))) toplevel-funobj) +(defmethod (setf borrowed-bindings) :before (x y) + (break "About to set borroweds for ~S to ~S." y x)) + (defun resolve-borrowed-bindings (toplevel-funobj) "For 's code, for every non-local binding used we create a borrowing-binding in the funobj-env. This process must be done @@ -479,23 +482,7 @@ (check-type toplevel-funobj movitz-funobj) (let ((function-binding-usage ())) (labels ((process-binding (funobj binding usages) - (typecase binding - (forwarding-binding - (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))))) - (cond - ((typep binding 'constant-object-binding) - binding) - ((eq funobj (binding-funobj binding)) - binding) - (t #+ignore (warn "binding ~S is not local to ~S [~S])) .." binding funobj - (mapcar #'borrowed-binding-target (borrowed-bindings funobj))) + (if (not (eq funobj (binding-funobj binding))) (let ((borrowing-binding (or (find binding (borrowed-bindings funobj) :key #'borrowed-binding-target) @@ -504,13 +491,39 @@ :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)) + #+ignore + (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)))) + borrowing-binding) + ;; Binding is local to this funobj + (typecase binding + (forwarding-binding + (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)))) + (t binding)))) (resolve-sub-funobj (funobj sub-funobj) (dolist (binding-we-lend (borrowed-bindings (resolve-funobj-borrowing sub-funobj))) + #+ignore + (warn "Lending from ~S to ~S: ~S <= ~S" + funobj sub-funobj + (borrowed-binding-target binding-we-lend) + binding-we-lend) (process-binding funobj (borrowed-binding-target binding-we-lend) (borrowed-binding-usage binding-we-lend)))) @@ -562,7 +575,8 @@ ;;; (multiple-value-bind (toplevel-funobj function-binding-usage) ;;; (resolve-borrowed-bindings toplevel-funobj) (assert (null (borrowed-bindings toplevel-funobj)) () - "Can't deal with toplevel closures yet.") + "Can't deal with toplevel closures yet. Borrowed: ~S" + (borrowed-bindings toplevel-funobj)) (setf (movitz-funobj-extent toplevel-funobj) :indefinite-extent) (let ((sub-funobj-index 0)) (loop for (function-binding usage) on function-binding-usage by #'cddr @@ -2371,7 +2385,7 @@ (list new-value) `(let ((,(car stores) (progn (assert (not (new-binding-located-p ,binding-var ,getter))) - (check-type ,new-value (or keyword (integer 0 *))) + (check-type ,new-value (or keyword binding (integer 0 *))) (acons ,binding-var ,new-value ,getter)))) ,setter ,new-value) @@ -2573,27 +2587,31 @@ free-so-far))) ((:load-constant :load-lexical :store-lexical :cons-get :endp :incf-lexvar :init-lexvar) (assert (gethash (instruction-is i) *extended-code-expanders*)) - (unless (can-expand-extended-p i frame-map) - (return (values nil t))) - (let ((exp (expand-extended-code i funobj frame-map))) - (when (tree-search exp '(:call :local-function-init)) - (setf free-so-far - (remove-if (lambda (r) - (not (eq r :push))) - free-so-far))) - (setf free-so-far - (remove-if (lambda (r) - (and (not (eq r :push)) - (or (tree-search exp r) - (tree-search exp (register32-to-low8 r))))) - free-so-far)))) + (cond + ((and (instruction-is i :init-lexvar) ; special case.. + (typep (second i) 'forwarding-binding))) + (t (unless (can-expand-extended-p i frame-map) + ;; (warn "can't expand ~A from ~A" i frame-map) + (return (values nil t))) + (let ((exp (expand-extended-code i funobj frame-map))) + (when (tree-search exp '(:call :local-function-init)) + (setf free-so-far + (remove-if (lambda (r) + (not (eq r :push))) + free-so-far))) + (setf free-so-far + (remove-if (lambda (r) + (and (not (eq r :push)) + (or (tree-search exp r) + (tree-search exp (register32-to-low8 r))))) + free-so-far)))))) ((:local-function-init) (destructuring-bind (binding) (cdr i) (unless (typep binding 'funobj-binding) (return nil)))) - (t (warn "Dist ~D stopped by ~A" - distance i) + (t #+ignore (warn "Dist ~D stopped by ~A" + distance i) (return nil))))) ;; do (warn "after ~A: ~A" i free-so-far) finally (return free-so-far))) @@ -2605,13 +2623,13 @@ (let* ((count-init-pc (gethash binding var-counts)) (count (car count-init-pc)) (init-pc (cdr count-init-pc))) - ;; (warn "b ~S: count: ~D, init-pc: ~{~&~A~}" binding count init-pc) (cond ((binding-lended-p binding) ;; We can't lend a register. (values nil :never)) ((and (= 1 count) init-pc) + ;; (warn "b ~S: count: ~D, init-pc: ~{~&~A~}" binding count init-pc) (assert (instruction-is (first init-pc) :init-lexvar)) (destructuring-bind (init-binding &key init-with-register init-with-type protect-registers protect-carry) @@ -2620,8 +2638,9 @@ (assert (eq binding init-binding)) (let* ((load-instruction (find-if (lambda (i) - (member binding (find-read-bindings i) - :test #'binding-eql)) + (and (not (instruction-is i :init-lexvar)) + (member binding (find-read-bindings i) + :test #'eq))) (cdr init-pc) :end 15)) (binding-destination (third load-instruction)) @@ -2674,7 +2693,7 @@ "Iterate over CODE, and take note in the hash-table VAR-COUNTER which ~ variables CODE references that are lexically bound in ENV." (check-type function-env function-env) - ;; (format t "~{~&~S~}" code) + ;; (print-code 'discover code) (let ((var-counter (make-hash-table :test #'eq :size 40))) (labels ((take-note-of-binding (binding &optional storep init-pc) (let ((count-init-pc (or (gethash binding var-counter) @@ -2685,17 +2704,17 @@ (setf (cdr count-init-pc) init-pc)) (unless storep (incf (car count-init-pc)))) + #+ignore (when (typep binding 'forwarding-binding) - (take-note-of-binding (forwarding-binding-target binding)))) + (take-note-of-binding (forwarding-binding-target binding) storep))) (do-discover-variables (code env) (loop for pc on code as instruction in code when (listp instruction) do (flet ((lend-lexical (borrowing-binding dynamic-extent-p) (let ((lended-binding (borrowed-binding-target borrowing-binding))) - (when (typep lended-binding 'forwarding-binding) - (setf lended-binding - (change-class lended-binding 'located-binding))) + (assert (not (typep lended-binding 'forwarding-binding)) () + "Can't lend a forwarding-binding.") (pushnew lended-binding (potentially-lended-bindings function-env)) (take-note-of-binding lended-binding) @@ -2724,7 +2743,10 @@ (cdr instruction) (declare (ignore protect-registers protect-carry init-with-type)) (when init-with-register - (take-note-of-binding binding t pc)))) + (take-note-of-binding binding t pc) + (when (and (typep init-with-register 'binding) + #+ignore (not (typep binding 'forwarding-binding))) + (take-note-of-binding init-with-register))))) (t (mapcar #'take-note-of-binding (find-read-bindings instruction)) (let ((store-binding (find-written-binding-and-type instruction))) @@ -2765,7 +2787,12 @@ ((not (typep binding 'lexical-binding))) ((typep binding 'lambda-binding)) ((typep binding 'constant-object-binding)) - ((typep binding 'forwarding-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) @@ -2778,7 +2805,7 @@ (unless (or (movitz-env-get variable 'ignore nil env nil) (movitz-env-get variable 'ignorable nil env nil) (typep binding 'hidden-rest-function-argument)) - (warn "Unused variable: ~S" variable))))) + (warn "Unused variable: ~S" binding))))) collect binding)) (bindings-fun-arg-sorted (when (eq env function-env) @@ -2919,7 +2946,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) + ;; (warn "Frame-map:~{ ~A~}" frame-map) frame-map))) @@ -3418,6 +3445,7 @@ (defun finalize-code (code funobj frame-map) ;; (print-code 'to-be-finalized code) + ;; (warn "frame-map: ~A" frame-map) (labels ((actual-binding (b) (if (typep b 'borrowed-binding) (borrowed-binding-target b) @@ -3481,92 +3509,92 @@ funobj frame-map))))) (t ;; (warn "finalizing ~S" instruction) - (case (first instruction) - ((:locally :globally) - (destructuring-bind (sub-instr) - (cdr instruction) - (let ((pf (ecase (first instruction) - (:locally *compiler-local-segment-prefix*) - (:globally *compiler-global-segment-prefix*)))) - (list (fix-edi-offset - (cond - ((atom sub-instr) - sub-instr) - ((consp (car sub-instr)) - (list* (append pf (car sub-instr)) - (cdr sub-instr))) - (t (list* pf sub-instr)))))))) - (:declare-label-set nil) - (:local-function-init - (destructuring-bind (function-binding) - (operands instruction) - #+ignore (warn "local-function-init: init ~S at ~S" - function-binding - (new-binding-location function-binding frame-map)) - (finalize-code - (let* ((sub-funobj (function-binding-funobj function-binding)) - (lend-code (loop for bb in (borrowed-bindings sub-funobj) - append (make-lend-lexical bb :edx nil)))) - (cond - ((typep function-binding 'funobj-binding) - nil) - ((null lend-code) - (warn "null lending") - (append (make-load-constant sub-funobj :eax funobj frame-map) - (make-store-lexical function-binding :eax nil frame-map))) - (t (append (make-load-constant sub-funobj :eax funobj frame-map) - `((:movl (:edi ,(global-constant-offset 'copy-funobj)) :esi) - (:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%1op))) - (:movl :eax :edx)) - (make-store-lexical function-binding :eax nil frame-map) - lend-code)))) - funobj frame-map))) - (:load-lambda - (destructuring-bind (function-binding register) - (operands instruction) - ;; (warn "load-lambda not completed for ~S" function-binding) - (finalize-code - (let* ((sub-funobj (function-binding-funobj function-binding)) - (lend-code (loop for bb in (borrowed-bindings sub-funobj) - appending - (make-lend-lexical bb :edx nil)))) - (cond - ((null lend-code) - ;; (warn "null lambda lending") - (append (make-load-constant sub-funobj register funobj frame-map))) - (t (append (make-load-constant sub-funobj :eax funobj frame-map) - `((:movl (:edi ,(global-constant-offset 'copy-funobj)) :esi) - (:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%1op))) - (:movl :eax :edx)) - lend-code - `((:movl :edx ,register)))))) - funobj frame-map))) - (:load-constant - (destructuring-bind (object result-mode &key (op :movl)) - (cdr instruction) - (make-load-constant object result-mode funobj frame-map :op op))) - (:lexical-control-transfer - (destructuring-bind (return-code return-mode from-env to-env &optional to-label) - (cdr instruction) - (declare (ignore return-code)) - (let ((x (apply #'make-compiled-lexical-control-transfer - nil - return-mode from-env to-env - (when to-label (list to-label))))) - (finalize-code x funobj frame-map)))) - (:call-lexical - (destructuring-bind (binding num-args) - (operands instruction) - (append (etypecase binding - (closure-binding - (make-load-lexical (ensure-local-binding binding) - :esi funobj nil frame-map - :tmp-register :edx)) - (funobj-binding - (make-load-constant (function-binding-funobj binding) - :esi funobj frame-map))) - (make-compiled-funcall-by-esi num-args)))) - (t (expand-extended-code instruction funobj frame-map))))))))) + (case (first instruction) + ((:locally :globally) + (destructuring-bind (sub-instr) + (cdr instruction) + (let ((pf (ecase (first instruction) + (:locally *compiler-local-segment-prefix*) + (:globally *compiler-global-segment-prefix*)))) + (list (fix-edi-offset + (cond + ((atom sub-instr) + sub-instr) + ((consp (car sub-instr)) + (list* (append pf (car sub-instr)) + (cdr sub-instr))) + (t (list* pf sub-instr)))))))) + (:declare-label-set nil) + (:local-function-init + (destructuring-bind (function-binding) + (operands instruction) + #+ignore (warn "local-function-init: init ~S at ~S" + function-binding + (new-binding-location function-binding frame-map)) + (finalize-code + (let* ((sub-funobj (function-binding-funobj function-binding)) + (lend-code (loop for bb in (borrowed-bindings sub-funobj) + append (make-lend-lexical bb :edx nil)))) + (cond + ((typep function-binding 'funobj-binding) + nil) + ((null lend-code) + (warn "null lending") + (append (make-load-constant sub-funobj :eax funobj frame-map) + (make-store-lexical function-binding :eax nil frame-map))) + (t (append (make-load-constant sub-funobj :eax funobj frame-map) + `((:movl (:edi ,(global-constant-offset 'copy-funobj)) :esi) + (:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%1op))) + (:movl :eax :edx)) + (make-store-lexical function-binding :eax nil frame-map) + lend-code)))) + funobj frame-map))) + (:load-lambda + (destructuring-bind (function-binding register) + (operands instruction) + ;; (warn "load-lambda not completed for ~S" function-binding) + (finalize-code + (let* ((sub-funobj (function-binding-funobj function-binding)) + (lend-code (loop for bb in (borrowed-bindings sub-funobj) + appending + (make-lend-lexical bb :edx nil)))) + (cond + ((null lend-code) + ;; (warn "null lambda lending") + (append (make-load-constant sub-funobj register funobj frame-map))) + (t (append (make-load-constant sub-funobj :eax funobj frame-map) + `((:movl (:edi ,(global-constant-offset 'copy-funobj)) :esi) + (:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%1op))) + (:movl :eax :edx)) + lend-code + `((:movl :edx ,register)))))) + funobj frame-map))) + (:load-constant + (destructuring-bind (object result-mode &key (op :movl)) + (cdr instruction) + (make-load-constant object result-mode funobj frame-map :op op))) + (:lexical-control-transfer + (destructuring-bind (return-code return-mode from-env to-env &optional to-label) + (cdr instruction) + (declare (ignore return-code)) + (let ((x (apply #'make-compiled-lexical-control-transfer + nil + return-mode from-env to-env + (when to-label (list to-label))))) + (finalize-code x funobj frame-map)))) + (:call-lexical + (destructuring-bind (binding num-args) + (operands instruction) + (append (etypecase binding + (closure-binding + (make-load-lexical (ensure-local-binding binding) + :esi funobj nil frame-map + :tmp-register :edx)) + (funobj-binding + (make-load-constant (function-binding-funobj binding) + :esi funobj frame-map))) + (make-compiled-funcall-by-esi num-args)))) + (t (expand-extended-code instruction funobj frame-map))))))))) (defun image-t-symbol-p (x) @@ -5801,17 +5829,32 @@ (assert init-with-type) (values binding init-with-type)))) +(define-find-read-bindings :init-lexvar (binding &key init-with-register &allow-other-keys) + (declare (ignore binding)) + (when (typep init-with-register 'binding) + (list init-with-register))) + (define-extended-code-expander :init-lexvar (instruction funobj frame-map) (destructuring-bind (binding &key protect-registers protect-carry init-with-register init-with-type) (cdr instruction) (declare (ignore protect-carry)) ; nothing modifies carry anyway. - (assert (eq binding (ensure-local-binding binding funobj))) + ;; (assert (eq binding (ensure-local-binding binding funobj))) + (assert (eq funobj (binding-funobj binding))) (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))) - (warn "Unused variable: ~S." (binding-name 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))) + (warn "Unused variable: ~S." binding))) + ((typep binding 'forwarding-binding) + ;; No need to do any initialization because the target will be initialized. + nil) (t (when (movitz-env-get (binding-name binding) 'ignore nil (binding-env binding)) (warn "Variable ~S used while declared ignored." (binding-name binding))) (append @@ -5835,24 +5878,34 @@ (make-compiled-funcall-by-symbol 'muerte.cl:copy-list 1 funobj))))) (cond ((binding-lended-p binding) - (let ((cons-position (getf (binding-lended-p binding) - :stack-cons-location)) - (tmp-register (find-if (lambda (r) - (and (not (member r protect-registers)) - (not (eq r init-with-register)))) - '(:edx :ecx :ebx :eax))) - (init-register (or init-with-register :edi))) + (let* ((cons-position (getf (binding-lended-p binding) + :stack-cons-location)) + (init-register (etypecase init-with-register + (lexical-binding + (or (find-if (lambda (r) + (not (member r protect-registers))) + '(:edx :ebx :eax)) + (error "Unable to get a register."))) + (keyword init-with-register) + (null :edi))) + (tmp-register (find-if (lambda (r) + (and (not (member r protect-registers)) + (not (eq r init-register)))) + '(:edx :ebx :eax)))) (when init-with-register (assert (not (null init-with-type)))) (assert tmp-register () ; solve this with push eax .. pop eax if ever needed. "Unable to find a tmp-register for ~S." instruction) - `((:leal (:ebp ,(1+ (stack-frame-offset (1+ cons-position)))) - ,tmp-register) - (:movl :edi (,tmp-register 3)) ; cdr - (:movl ,init-register (,tmp-register -1)) ; car - (:movl ,tmp-register - (:ebp ,(stack-frame-offset - (new-binding-location binding frame-map))))))) + (append (when (typep init-with-register 'binding) + (make-load-lexical init-with-register init-register funobj nil frame-map + :protect-registers protect-registers)) + `((:leal (:ebp ,(1+ (stack-frame-offset (1+ cons-position)))) + ,tmp-register) + (:movl :edi (,tmp-register 3)) ; cdr + (:movl ,init-register (,tmp-register -1)) ; car + (:movl ,tmp-register + (:ebp ,(stack-frame-offset + (new-binding-location binding frame-map)))))))) (init-with-register (make-store-lexical binding init-with-register nil frame-map)))))))) From ffjeld at common-lisp.net Wed Jun 9 17:26:07 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 10:26:07 -0700 Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv7729 Modified Files: special-operators-cl.lisp Log Message: Quite a bit of cruft regarding register allocation etc. Still more work to do here, but I don't have time for it right now.. Date: Wed Jun 9 10:26:07 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.17 movitz/special-operators-cl.lisp:1.18 --- movitz/special-operators-cl.lisp:1.17 Tue Apr 13 09:55:08 2004 +++ movitz/special-operators-cl.lisp Wed Jun 9 10:26:07 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.17 2004/04/13 16:55:08 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.18 2004/06/09 17:26:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -212,14 +212,20 @@ :load t :store t)) rest-codes)))))) - ;; replace read-only lexical binding with the outer lexical binding - ;; (warn "replace ~S with outer ~S" var (second (first init-code))) - (change-class binding 'forwarding-binding - :target-binding (second (first init-code))) - nil) + ;; 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))) + (let ((target (second (first init-code)))) + (change-class binding 'forwarding-binding + :target-binding target) + `((: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))) + (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" From ffjeld at common-lisp.net Wed Jun 9 19:35:22 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 12:35:22 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv21589 Modified Files: basic-macros.lisp Log Message: Removed bogus compiler-macro for fifth. Date: Wed Jun 9 12:35:22 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.23 movitz/losp/muerte/basic-macros.lisp:1.24 --- movitz/losp/muerte/basic-macros.lisp:1.23 Wed Jun 9 10:23:16 2004 +++ movitz/losp/muerte/basic-macros.lisp Wed Jun 9 12:35:22 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.23 2004/06/09 17:23:16 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.24 2004/06/09 19:35:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -609,7 +609,6 @@ (define-compiler-macro second (x) `(cadr ,x)) (define-compiler-macro third (x) `(caddr ,x)) (define-compiler-macro fourth (x) `(cadddr ,x)) -(define-compiler-macro fifth (x) `(caddddr ,x)) (define-compiler-macro (setf car) (value cell &environment env) (if (and (movitz:movitz-constantp value env) From ffjeld at common-lisp.net Wed Jun 9 20:13:16 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 13:13:16 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9640 Modified Files: typep.lisp Log Message: Added a rather stupid coerce function. Date: Wed Jun 9 13:13:16 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.14 movitz/losp/muerte/typep.lisp:1.15 --- movitz/losp/muerte/typep.lisp:1.14 Wed Jun 9 10:21:47 2004 +++ movitz/losp/muerte/typep.lisp Wed Jun 9 13:13:16 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.14 2004/06/09 17:21:47 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.15 2004/06/09 20:13:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -564,28 +564,11 @@ (defun type-of (x) (class-name (class-of x))) -;;; (typecase x -;;; (null 'null) -;;; (cons 'cons) -;;; (symbol 'symbol) -;;; (integer 'integer) -;;; (structure-object -;;; (structure-object-name x)) -;;; (t t))) +(defun coerce (object result-type) + "=> result" + (cond + ((typep object result-type) + object) + (t (error "Don't know how to coerce ~S to ~S." object result-type)))) - -;;;(defun subtypep (type-1 type-2) -;;; (cond -;;; ((eq type-1 type-2) -;;; t) -;;; ((or (atom type-1) (atom type-2)) -;;; nil) -;;; ((equal type-1 type-2) -;;; t) -;;; (t (case (car type-2) -;;; (integer -;;; (let ((low2 (second type-2)) -;;; (hi2 (third type-2))) -;;; (case (car type-1) - From ffjeld at common-lisp.net Wed Jun 9 20:18:45 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 13:18:45 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/lists.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13331 Modified Files: lists.lisp Log Message: Added adjoin. Date: Wed Jun 9 13:18:45 2004 Author: ffjeld Index: movitz/losp/muerte/lists.lisp diff -u movitz/losp/muerte/lists.lisp:1.4 movitz/losp/muerte/lists.lisp:1.5 --- movitz/losp/muerte/lists.lisp:1.4 Thu Mar 18 01:24:23 2004 +++ movitz/losp/muerte/lists.lisp Wed Jun 9 13:18:45 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.4 2004/03/18 09:24:23 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.5 2004/06/09 20:18:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -436,3 +436,18 @@ +(defun subsetp (list-1 list-2 &key (key 'identity) (test 'eql) test-not) + "=> generalized-boolean" + (let ((test (if test-not + (complement test-not) + test))) + (dolist (x list-1 t) + (unless (member x list-2 :key key :test test) + (return nil))))) + +(defun adjoin (item list &key (key 'identity) (test 'eql) test-not) + "=> new-list" + (let ((test (if test-not (complement test-not) test))) + (if (member (funcall key item) list :test test) + list + (cons item list)))) From ffjeld at common-lisp.net Wed Jun 9 20:23:15 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 13:23:15 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18048 Modified Files: integers.lisp Log Message: Added function ceiling. Moved some bignum operators to inspect.lisp. Date: Wed Jun 9 13:23:15 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.28 movitz/losp/muerte/integers.lisp:1.29 --- movitz/losp/muerte/integers.lisp:1.28 Tue Jun 8 18:16:56 2004 +++ movitz/losp/muerte/integers.lisp Wed Jun 9 13:23:15 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.28 2004/06/09 01:16:56 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.29 2004/06/09 20:23:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1242,6 +1242,12 @@ (values quotient remainder)) (t (values (1- quotient) (- remainder))))))))) +(defun ceiling (number &optional (divisor 1)) + (case (+ (if (minusp number) #b10 0) + (if (minusp divisor) #b01 0)) + (#b00 (truncate (+ number divisor -1) divisor)) + (t (error "Don't know.")))) + (defun rem (dividend divisor) (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) dividend) @@ -1985,35 +1991,3 @@ (t (values (1- q) (+ r divisor)))))) (t (n &optional (divisor 1)) (floor n divisor)))) - -(define-compiler-macro %bignum-bigits (x) - `(with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) ,x) - (:movzxw (:eax #.(bt:slot-offset 'movitz::movitz-bignum - 'movitz::length)) - :ecx) - (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) - :eax))) - -(defun %bignum-bigits (x) - (%bignum-bigits x)) - -(defun copy-bignum (old) - (check-type old bignum) - (let* ((length (1+ (%bignum-bigits old))) - (new (malloc-data-words length))) - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ebx) new old) - (:compile-form (:result-mode :edx) length) - copy-bignum-loop - (:subl #.movitz:+movitz-fixnum-factor+ :edx) - (:movl (:ebx :edx #.movitz:+other-type-offset+) :ecx) - (:movl :ecx (:eax :edx #.movitz:+other-type-offset+)) - (:jnz 'copy-bignum-loop)))) - -(defun print-bignum (x) - (check-type x bignum) - (dotimes (i (1+ (%bignum-bigits x))) - (format t "~8,'0X " (memref x -6 i :unsigned-byte32))) - (terpri) - (values)) \ No newline at end of file From ffjeld at common-lisp.net Wed Jun 9 20:23:48 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 13:23:48 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv21599 Modified Files: inspect.lisp Log Message: Moved some bignum operators here from integers.lisp. Date: Wed Jun 9 13:23:48 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.10 movitz/losp/muerte/inspect.lisp:1.11 --- movitz/losp/muerte/inspect.lisp:1.10 Wed Jun 2 16:21:13 2004 +++ movitz/losp/muerte/inspect.lisp Wed Jun 9 13:23:48 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.10 2004/06/02 23:21:13 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.11 2004/06/09 20:23:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -268,3 +268,26 @@ (+ -1 object-location #.(movitz::movitz-type-word-size :movitz-struct) (* 2 (truncate (+ (structure-object-length object) 1) 2)))))))) + +(defun %bignum-bigits (x) + (%bignum-bigits x)) + +(defun copy-bignum (old) + (check-type old bignum) + (let* ((length (1+ (%bignum-bigits old))) + (new (malloc-data-words length))) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) new old) + (:compile-form (:result-mode :edx) length) + copy-bignum-loop + (:subl #.movitz:+movitz-fixnum-factor+ :edx) + (:movl (:ebx :edx #.movitz:+other-type-offset+) :ecx) + (:movl :ecx (:eax :edx #.movitz:+other-type-offset+)) + (:jnz 'copy-bignum-loop)))) + +(defun print-bignum (x) + (check-type x bignum) + (dotimes (i (1+ (%bignum-bigits x))) + (format t "~8,'0X " (memref x -6 i :unsigned-byte32))) + (terpri) + (values)) From ffjeld at common-lisp.net Wed Jun 9 20:24:29 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 13:24:29 -0700 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29818 Modified Files: compiler.lisp Log Message: Still some tweaking of register allocation stuff. Date: Wed Jun 9 13:24:29 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.64 movitz/compiler.lisp:1.65 --- movitz/compiler.lisp:1.64 Wed Jun 9 10:26:00 2004 +++ movitz/compiler.lisp Wed Jun 9 13:24:29 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.64 2004/06/09 17:26:00 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.65 2004/06/09 20:24:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5825,9 +5825,12 @@ protect-registers protect-carry) (cdr instruction) (declare (ignore protect-registers protect-carry)) - (when init-with-register + (cond + (init-with-register (assert init-with-type) - (values binding init-with-type)))) + (values binding init-with-type)) + ((not (typep binding 'temporary-name)) + (values binding t))))) (define-find-read-bindings :init-lexvar (binding &key init-with-register &allow-other-keys) (declare (ignore binding)) From ffjeld at common-lisp.net Wed Jun 9 20:33:31 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 13:33:31 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12302 Modified Files: integers.lisp Log Message: Added a horrible isqrt. Date: Wed Jun 9 13:33:31 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.29 movitz/losp/muerte/integers.lisp:1.30 --- movitz/losp/muerte/integers.lisp:1.29 Wed Jun 9 13:23:15 2004 +++ movitz/losp/muerte/integers.lisp Wed Jun 9 13:33:31 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.29 2004/06/09 20:23:15 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.30 2004/06/09 20:33:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1991,3 +1991,9 @@ (t (values (1- q) (+ r divisor)))))) (t (n &optional (divisor 1)) (floor n divisor)))) + +(defun isqrt (natural) + "=> natural-root" + (check-type natural (integer 0 *)) + (do ((i 0 (1+ i))) + ((> (* i i) natural) (1- i)))) \ No newline at end of file From ffjeld at common-lisp.net Wed Jun 9 22:52:12 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 15:52:12 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4087 Modified Files: integers.lisp Log Message: Added a bad expt. And a decent integer-length. Date: Wed Jun 9 15:52:12 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.30 movitz/losp/muerte/integers.lisp:1.31 --- movitz/losp/muerte/integers.lisp:1.30 Wed Jun 9 13:33:31 2004 +++ movitz/losp/muerte/integers.lisp Wed Jun 9 15:52:12 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.30 2004/06/09 20:33:31 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.31 2004/06/09 22:52:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -788,6 +788,34 @@ (when (< x min) (setq min x))))) +;;; Types + +(define-typep integer (x &optional (min '*) (max '*)) + (and (typep x 'integer) + (or (eq min '*) (<= min x)) + (or (eq max '*) (<= x max)))) + +(deftype signed-byte (&optional (size '*)) + (cond + ((eq size '*) + 'integer) + ((typep size '(integer 1 *)) + (list 'integer + (- (ash 1 (1- size))) + (1- (ash 1 (1- size))))) + (t (error "Illegal size for signed-byte.")))) + +(deftype unsigned-byte (&optional (size '*)) + (cond + ((eq size '*) + '(integer 0)) + ((typep size '(integer 1 *)) + (list 'integer 0 (1- (ash 1 size)))) + (t (error "Illegal size for unsigned-byte.")))) + +(define-simple-typep (bit bitp) (x) + (or (eq x 0) (eq x 1))) + ;; shift (define-compiler-macro ash (&whole form integer count &environment env) @@ -857,6 +885,43 @@ (:andb #.(cl:logxor #xff movitz::+movitz-fixnum-zmask+) :al))) (t (if (= 0 integer) 0 (error "Illegal ash count: ~D" count))))) +(defun integer-length (integer) + "=> number-of-bits" + (etypecase integer + (fixnum + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:xorl :eax :eax) + (:compile-form (:result-mode :ecx) integer) + (:testl :ecx :ecx) + (:jns 'not-negative) + (:notl :ecx) + not-negative + (:bsrl :ecx :ecx) + (:jz 'zero) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) + ,(* -1 movitz:+movitz-fixnum-factor+)) + :eax) + zero))) + (do-it))) + (positive-bignum + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :ebx) integer) + (:movzxw (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length)) + :ecx) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,(* -1 movitz:+movitz-fixnum-factor+)) + :eax) ; bigits-1 + (:bsrl (:ebx (:ecx 4) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + :ecx) + (:shll 5 :eax) ; bits = bigits*32 + (bit-index+1) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) :eax + ,movitz:+movitz-fixnum-factor+) + :eax)))) + (do-it))))) + ;;; Multiplication (define-compiler-macro * (&whole form &rest operands &environment env) @@ -1910,34 +1975,6 @@ (logior (mask-field bytespec newbyte) (logandc2 integer (mask-field bytespec -1)))) -;;; Types - -(define-typep integer (x &optional (min '*) (max '*)) - (and (typep x 'integer) - (or (eq min '*) (<= min x)) - (or (eq max '*) (<= x max)))) - -(deftype signed-byte (&optional (size '*)) - (cond - ((eq size '*) - 'integer) - ((typep size '(integer 1 *)) - (list 'integer - (- (ash 1 (1- size))) - (1- (ash 1 (1- size))))) - (t (error "Illegal size for signed-byte.")))) - -(deftype unsigned-byte (&optional (size '*)) - (cond - ((eq size '*) - '(integer 0)) - ((typep size '(integer 1 *)) - (list 'integer 0 (1- (ash 1 size)))) - (t (error "Illegal size for unsigned-byte.")))) - -(define-simple-typep (bit bitp) (x) - (or (eq x 0) (eq x 1))) - ;;; (defun plus-if (x y) @@ -1996,4 +2033,19 @@ "=> natural-root" (check-type natural (integer 0 *)) (do ((i 0 (1+ i))) - ((> (* i i) natural) (1- i)))) \ No newline at end of file + ((> (* i i) natural) (1- i)))) + +(define-compiler-macro expt (&whole form base-number power-number &environment env) + (if (not (and (movitz:movitz-constantp base-number env) + (movitz:movitz-constantp power-number env))) + form + (expt (movitz:movitz-eval base-number env) + (movitz:movitz-eval power-number env)))) + + +(defun expt (base-number power-number) + "Take base-number to the power-number." + (do ((i 0 (1+ i)) + (r 1 (* r base-number))) + ((>= i power-number) r))) + From ffjeld at common-lisp.net Wed Jun 9 22:55:37 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 15:55:37 -0700 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv8436 Modified Files: compiler.lisp Log Message: Removed some debris. Date: Wed Jun 9 15:55:37 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.65 movitz/compiler.lisp:1.66 --- movitz/compiler.lisp:1.65 Wed Jun 9 13:24:29 2004 +++ movitz/compiler.lisp Wed Jun 9 15:55:37 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.65 2004/06/09 20:24:29 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.66 2004/06/09 22:55:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -470,9 +470,6 @@ (type-specifier-encode 'list))))) binding-usage)))) toplevel-funobj) - -(defmethod (setf borrowed-bindings) :before (x y) - (break "About to set borroweds for ~S to ~S." y x)) (defun resolve-borrowed-bindings (toplevel-funobj) "For 's code, for every non-local binding used we create From ffjeld at common-lisp.net Wed Jun 9 23:00:58 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 16:00:58 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/lib/malloc-init.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv14421 Modified Files: malloc-init.lisp Log Message: We'll start allocating at 2MB rather than 1MB, leaving more space for the kernel. Date: Wed Jun 9 16:00:57 2004 Author: ffjeld Index: movitz/losp/lib/malloc-init.lisp diff -u movitz/losp/lib/malloc-init.lisp:1.2 movitz/losp/lib/malloc-init.lisp:1.3 --- movitz/losp/lib/malloc-init.lisp:1.2 Mon Jan 19 03:23:44 2004 +++ movitz/losp/lib/malloc-init.lisp Wed Jun 9 16:00:57 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Jan 9 15:57:22 2002 ;;;; -;;;; $Id: malloc-init.lisp,v 1.2 2004/01/19 11:23:44 ffjeld Exp $ +;;;; $Id: malloc-init.lisp,v 1.3 2004/06/09 23:00:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -20,7 +20,7 @@ (in-package muerte.lib) (let ((memsize (muerte.x86-pc::memory-size)) - (start (truncate (* 1 1024 1024) 4096))) + (start (truncate (* 2 1024 1024) 4096))) ; XXX We really should calcucalte this.. ;; (format t "Memory: ~D MB.~%" memsize) (muerte:malloc-initialize start (- (* memsize #x100) start))) From ffjeld at common-lisp.net Wed Jun 9 23:04:26 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 16:04:26 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18632 Modified Files: more-macros.lisp Log Message: Moved %bignum-bigits compiler-macro here. Date: Wed Jun 9 16:04:26 2004 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.9 movitz/losp/muerte/more-macros.lisp:1.10 --- movitz/losp/muerte/more-macros.lisp:1.9 Wed Jun 9 10:22:51 2004 +++ movitz/losp/muerte/more-macros.lisp Wed Jun 9 16:04:26 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.9 2004/06/09 17:22:51 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.10 2004/06/09 23:04:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -311,6 +311,15 @@ (let ((,object-var ,instance-form)) , at declarations-and-forms)))) + +(define-compiler-macro %bignum-bigits (x) + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) ,x) + (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum + 'movitz::length)) + :ecx) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) + :eax))) ;;; Some macros that aren't implemented, and we want to give compiler errors. From ffjeld at common-lisp.net Wed Jun 9 23:05:34 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 16:05:34 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv21062 Modified Files: typep.lisp Log Message: Small fix. Date: Wed Jun 9 16:05:34 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.15 movitz/losp/muerte/typep.lisp:1.16 --- movitz/losp/muerte/typep.lisp:1.15 Wed Jun 9 13:13:16 2004 +++ movitz/losp/muerte/typep.lisp Wed Jun 9 16:05:34 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.15 2004/06/09 20:13:16 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.16 2004/06/09 23:05:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -253,7 +253,8 @@ (when deriver-function `(typep ,object ',(funcall deriver-function))))))) ((consp type) - (let ((deriver-function (gethash (car type) *compiler-derived-typespecs*))) + (let ((deriver-function (gethash (translate-program (car type) :cl :muerte.cl) + *compiler-derived-typespecs*))) (if deriver-function `(typep ,object ',(apply deriver-function (cdr type))) (case (car type) @@ -372,7 +373,8 @@ (,(car type) ,@(loop for subtype in (cdr type) collect `(typep typep-object ',subtype))))) - (t (warn "compiling typep ~A" type))))))) + (t (warn "compiling typep ~S [~A]" type + (package-name (symbol-package (car type)))))))))) form))))) #+ignore From ffjeld at common-lisp.net Thu Jun 10 01:25:27 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 18:25:27 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv22039 Modified Files: integers.lisp Log Message: Minor shifting around of code. Date: Wed Jun 9 18:25:27 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.31 movitz/losp/muerte/integers.lisp:1.32 --- movitz/losp/muerte/integers.lisp:1.31 Wed Jun 9 15:52:12 2004 +++ movitz/losp/muerte/integers.lisp Wed Jun 9 18:25:27 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.31 2004/06/09 22:52:12 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.32 2004/06/10 01:25:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -788,34 +788,6 @@ (when (< x min) (setq min x))))) -;;; Types - -(define-typep integer (x &optional (min '*) (max '*)) - (and (typep x 'integer) - (or (eq min '*) (<= min x)) - (or (eq max '*) (<= x max)))) - -(deftype signed-byte (&optional (size '*)) - (cond - ((eq size '*) - 'integer) - ((typep size '(integer 1 *)) - (list 'integer - (- (ash 1 (1- size))) - (1- (ash 1 (1- size))))) - (t (error "Illegal size for signed-byte.")))) - -(deftype unsigned-byte (&optional (size '*)) - (cond - ((eq size '*) - '(integer 0)) - ((typep size '(integer 1 *)) - (list 'integer 0 (1- (ash 1 size)))) - (t (error "Illegal size for unsigned-byte.")))) - -(define-simple-typep (bit bitp) (x) - (or (eq x 0) (eq x 1))) - ;; shift (define-compiler-macro ash (&whole form integer count &environment env) @@ -884,6 +856,36 @@ (:sarl :cl :eax) (:andb #.(cl:logxor #xff movitz::+movitz-fixnum-zmask+) :al))) (t (if (= 0 integer) 0 (error "Illegal ash count: ~D" count))))) + +;;; Types + +(define-typep integer (x &optional (min '*) (max '*)) + (and (typep x 'integer) + (or (eq min '*) (<= min x)) + (or (eq max '*) (<= x max)))) + +(deftype signed-byte (&optional (size '*)) + (cond + ((eq size '*) + 'integer) + ((typep size '(integer 1 *)) + (list 'integer + (- (ash 1 (1- size))) + (1- (ash 1 (1- size))))) + (t (error "Illegal size for signed-byte.")))) + +(deftype unsigned-byte (&optional (size '*)) + (cond + ((eq size '*) + '(integer 0)) + ((typep size '(integer 1 *)) + (list 'integer 0 (1- (ash 1 size)))) + (t (error "Illegal size for unsigned-byte.")))) + +(define-simple-typep (bit bitp) (x) + (or (eq x 0) (eq x 1))) + +;;;; (defun integer-length (integer) "=> number-of-bits" From ffjeld at common-lisp.net Thu Jun 10 01:30:31 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 18:30:31 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3889 Modified Files: integers.lisp Log Message: Re-wrote rem in terms of truncate, taking advantage of truncate's bignum support. Date: Wed Jun 9 18:30:31 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.32 movitz/losp/muerte/integers.lisp:1.33 --- movitz/losp/muerte/integers.lisp:1.32 Wed Jun 9 18:25:27 2004 +++ movitz/losp/muerte/integers.lisp Wed Jun 9 18:30:31 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.32 2004/06/10 01:25:27 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.33 2004/06/10 01:30:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1316,18 +1316,7 @@ (t (error "Don't know.")))) (defun rem (dividend divisor) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) dividend) - (:compile-form (:result-mode :ebx) divisor) - (:movl :eax :ecx) - (:orl :ebx :ecx) - (:testb #.movitz::+movitz-fixnum-zmask+ :cl) - (:jnz '(:sub-program (not-integer) (:int 107))) - (:cdq :eax :edx) - (:idivl :ebx :eax :edx) - (:movl :edx :eax))) - - + (nth-value 1 (truncate dividend divisor))) (defun mod (number divisor) "Returns second result of FLOOR." From ffjeld at common-lisp.net Thu Jun 10 01:51:26 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 18:51:26 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1378 Modified Files: integers.lisp Log Message: A simple but working ash. Date: Wed Jun 9 18:51:26 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.33 movitz/losp/muerte/integers.lisp:1.34 --- movitz/losp/muerte/integers.lisp:1.33 Wed Jun 9 18:30:31 2004 +++ movitz/losp/muerte/integers.lisp Wed Jun 9 18:51:26 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.33 2004/06/10 01:30:31 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.34 2004/06/10 01:51:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -835,27 +835,35 @@ ((minusp count) `(if (minusp ,integer) -1 0)) (t `(if (= 0 ,integer) 0 (with-inline-assembly (:returns :non-local-exit) (:int 4))))))))))) - + (defun ash (integer count) - (check-type integer fixnum) - (check-type count fixnum) (cond - ((= 0 count) - integer) - ((<= 1 count 29) + ((not (minusp count)) (dotimes (i count integer) - (setq integer (ash integer 1)))) - ((<= count #.(cl:- 1 movitz::+movitz-fixnum-bits+)) - (if (minusp integer) -1 0)) - ((minusp count) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :ecx) count) - (:compile-form (:result-mode :eax) integer) - (:negl :ecx) - (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) - (:sarl :cl :eax) - (:andb #.(cl:logxor #xff movitz::+movitz-fixnum-zmask+) :al))) - (t (if (= 0 integer) 0 (error "Illegal ash count: ~D" count))))) + (setf integer (no-macro-call * 2 integer)))) + (t (dotimes (i (- count) integer) + (setf integer (truncate integer 2)))))) + +;;;(defun ash (integer count) +;;; (check-type integer fixnum) +;;; (check-type count fixnum) +;;; (cond +;;; ((= 0 count) +;;; integer) +;;; ((<= 1 count 29) +;;; (dotimes (i count integer) +;;; (setq integer (ash integer 1)))) +;;; ((<= count #.(cl:- 1 movitz::+movitz-fixnum-bits+)) +;;; (if (minusp integer) -1 0)) +;;; ((minusp count) +;;; (with-inline-assembly (:returns :eax) +;;; (:compile-form (:result-mode :ecx) count) +;;; (:compile-form (:result-mode :eax) integer) +;;; (:negl :ecx) +;;; (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) +;;; (:sarl :cl :eax) +;;; (:andb #.(cl:logxor #xff movitz::+movitz-fixnum-zmask+) :al))) +;;; (t (if (= 0 integer) 0 (error "Illegal ash count: ~D" count))))) ;;; Types From ffjeld at common-lisp.net Thu Jun 10 02:13:19 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 09 Jun 2004 19:13:19 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2187 Modified Files: integers.lisp Log Message: Imrpoved logandc1 and logandc2. Date: Wed Jun 9 19:13:19 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.34 movitz/losp/muerte/integers.lisp:1.35 --- movitz/losp/muerte/integers.lisp:1.34 Wed Jun 9 18:51:26 2004 +++ movitz/losp/muerte/integers.lisp Wed Jun 9 19:13:19 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.34 2004/06/10 01:51:26 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.35 2004/06/10 02:13:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1422,22 +1422,42 @@ ,@(cddr constant-folded-integers)))))) (defun logandc1 (integer1 integer2) - (check-type integer1 fixnum) - (check-type integer2 fixnum) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) integer1) - (:compile-form (:result-mode :ebx) integer2) - (:notl :eax) - (:andl :ebx :eax))) + (number-double-dispatch (integer1 integer2) + ((t positive-fixnum) + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) integer1) + (:call-global-constant unbox-u32) + (:shll #.movitz:+movitz-fixnum-shift+ :ecx) + (:compile-form (:result-mode :eax) integer2) + (:notl :ecx) + (:andl :ecx :eax))) + ((positive-fixnum t) + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) integer2) + (:call-global-constant unbox-u32) + (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) :eax) + (:compile-form (:result-mode :ecx) integer1) + (:notl :ecx) + (:andl :ecx :eax))))) (defun logandc2 (integer1 integer2) - (check-type integer1 fixnum) - (check-type integer2 fixnum) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) integer1) - (:compile-form (:result-mode :ebx) integer2) - (:notl :ebx) - (:andl :ebx :eax))) + (number-double-dispatch (integer1 integer2) + ((positive-fixnum t) + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) integer2) + (:call-global-constant unbox-u32) + (:shll #.movitz:+movitz-fixnum-shift+ :ecx) + (:compile-form (:result-mode :eax) integer1) + (:notl :ecx) + (:andl :ecx :eax))) + ((t positive-fixnum) + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) integer1) + (:call-global-constant unbox-u32) + (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) :eax) + (:compile-form (:result-mode :ecx) integer2) + (:notl :ecx) + (:andl :ecx :eax))))) (defun logior%2op (x y) (with-inline-assembly (:returns :eax) From ffjeld at common-lisp.net Thu Jun 10 12:05:56 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 10 Jun 2004 05:05:56 -0700 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv2108 Modified Files: compiler.lisp Log Message: Fixed nasty omission of functionality for functions with arglist like (x &optional y). Still somewhat missing, but at least now it will complain rather than silently produce faulty code. Date: Thu Jun 10 05:05:56 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.66 movitz/compiler.lisp:1.67 --- movitz/compiler.lisp:1.66 Wed Jun 9 15:55:37 2004 +++ movitz/compiler.lisp Thu Jun 10 05:05:56 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.66 2004/06/09 22:55:37 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.67 2004/06/10 12:05:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -723,6 +723,21 @@ (t (error "Can't deal with optional-p at ~S, after (~S ~S)." optp-location req-location opt-location))) (make-stack-setup-code (- stack-frame-size stack-setup-pre)) + (when (binding-lended-p req-binding) + (let ((lended-cons-position (getf (binding-lended-p req-binding) + :stack-cons-location))) + (etypecase req-location + (integer + `((:movl (:ebp ,(stack-frame-offset req-location)) :edx) + (:movl :edi (:ebp ,(stack-frame-offset lended-cons-position))) ; cdr + (:movl :edx (:ebp ,(stack-frame-offset (1+ lended-cons-position)))) ; car + (:leal (:ebp 1 ,(stack-frame-offset (1+ lended-cons-position))) + :edx) + (:movl :edx (:ebp ,(stack-frame-offset req-location)))))))) + (when (binding-lended-p opt-binding) + (error "Can't deal with lending optional right now.")) + (when (and optp-binding (binding-lended-p optp-binding)) + (error "Can't deal with lending optionalp right now.")) resolved-code (make-compiled-function-postlude funobj function-env use-stack-frame-p))))) @@ -798,7 +813,7 @@ (and code2 (eq x 'entry%2op)) (and code3 (eq x 'entry%3op)))) codet))))) - ;; (warn "opt code: ~{~&~A~}" optimized-function-code) + ;; (print-code funobj combined-code) (assemble-funobj funobj combined-code)))) funobj) @@ -5839,6 +5854,8 @@ init-with-register init-with-type) (cdr instruction) (declare (ignore protect-carry)) ; nothing modifies carry anyway. + (when (string= (binding-name binding) 'reader-function) + (break "init: ~S" instruction)) ;; (assert (eq binding (ensure-local-binding binding funobj))) (assert (eq funobj (binding-funobj binding))) (cond @@ -5854,6 +5871,7 @@ (warn "Unused variable: ~S." binding))) ((typep binding 'forwarding-binding) ;; No need to do any initialization because the target will be initialized. + (assert (not (binding-lended-p binding))) nil) (t (when (movitz-env-get (binding-name binding) 'ignore nil (binding-env binding)) (warn "Variable ~S used while declared ignored." (binding-name binding))) From ffjeld at common-lisp.net Thu Jun 10 12:07:02 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 10 Jun 2004 05:07:02 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/conditions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2551 Modified Files: conditions.lisp Log Message: Added condition undefined-function-call as a subclass of undefined-function. Date: Thu Jun 10 05:07:02 2004 Author: ffjeld Index: movitz/losp/muerte/conditions.lisp diff -u movitz/losp/muerte/conditions.lisp:1.6 movitz/losp/muerte/conditions.lisp:1.7 --- movitz/losp/muerte/conditions.lisp:1.6 Sun Apr 18 16:17:36 2004 +++ movitz/losp/muerte/conditions.lisp Thu Jun 10 05:07:02 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.6 2004/04/18 23:17:36 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.7 2004/06/10 12:07:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -79,6 +79,15 @@ (:report (lambda (c s) (format s "Undefined function ~S." (cell-error-name c))))) + +(define-condition undefined-function-call (undefined-function) + ((arguments + :initarg :arguments + :reader undefined-function-call-arguments)) + (:report (lambda (c s) + (format s "Undefined function ~S called with arguments ~:S." + (cell-error-name c) + (undefined-function-call-arguments c))))) (define-condition unbound-variable (cell-error) () From ffjeld at common-lisp.net Thu Jun 10 12:09:15 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 10 Jun 2004 05:09:15 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10838 Modified Files: functions.lisp Log Message: Made unbound-function produce an undefined-function-call error, rather than just undefined-function. Date: Thu Jun 10 05:09:15 2004 Author: ffjeld Index: movitz/losp/muerte/functions.lisp diff -u movitz/losp/muerte/functions.lisp:1.11 movitz/losp/muerte/functions.lisp:1.12 --- movitz/losp/muerte/functions.lisp:1.11 Fri Apr 23 08:05:35 2004 +++ movitz/losp/muerte/functions.lisp Thu Jun 10 05:09:15 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 12 22:58:54 2002 ;;;; -;;;; $Id: functions.lisp,v 1.11 2004/04/23 15:05:35 ffjeld Exp $ +;;;; $Id: functions.lisp,v 1.12 2004/06/10 12:09:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -75,14 +75,17 @@ (not (apply function args)))) (defun unbound-function (&edx edx &rest args) - (declare (ignore args)) + "This is the function that is the unbound value for function cells." + (declare (dynamic-extent args)) (let ((function-name (typecase edx (symbol edx) (compiled-function (funobj-name edx)) (t '(unknown))))) - (error 'undefined-function :name function-name))) + (error 'undefined-function-call + :name function-name + :arguments (copy-list args)))) ;;; funobj object From ffjeld at common-lisp.net Thu Jun 10 12:19:47 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 10 Jun 2004 05:19:47 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv21696 Modified Files: primitive-functions.lisp Log Message: Make ensure-heap-cons-variable be more defensive: Check that the old value is a cons/list. Date: Thu Jun 10 05:19:47 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.20 movitz/losp/muerte/primitive-functions.lisp:1.21 --- movitz/losp/muerte/primitive-functions.lisp:1.20 Mon Jun 7 15:16:53 2004 +++ movitz/losp/muerte/primitive-functions.lisp Thu Jun 10 05:19:47 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.20 2004/06/07 22:16:53 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.21 2004/06/10 12:19:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -491,6 +491,10 @@ (define-primitive-function ensure-heap-cons-variable () "Call with lended variable (a cons) in EAX. Preserves EDX." (with-inline-assembly (:returns :multiple-values) + ;; Be defensive: Check that EAX is LISTP. + (:leal (:eax -1) :ecx) + (:testb 3 :cl) + (:jnz '(:sub-program () (:int 50))) (:cmpl :ebp :eax) ; is cons above stack-frame? (:jge 'return-ok) (:cmpl :esp :eax) ; is cons below stack-frame? From ffjeld at common-lisp.net Thu Jun 10 12:21:11 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 10 Jun 2004 05:21:11 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24484 Modified Files: sequences.lisp Log Message: Added a trivial delete-if-not, and incomplete make-sequence and concatenate. Date: Thu Jun 10 05:21:11 2004 Author: ffjeld Index: movitz/losp/muerte/sequences.lisp diff -u movitz/losp/muerte/sequences.lisp:1.8 movitz/losp/muerte/sequences.lisp:1.9 --- movitz/losp/muerte/sequences.lisp:1.8 Thu May 20 10:48:04 2004 +++ movitz/losp/muerte/sequences.lisp Thu Jun 10 05:21:11 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.8 2004/05/20 17:48:04 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.9 2004/06/10 12:21:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1268,6 +1268,10 @@ (vector (error "vector delete-if not implemented.")))) +(defun delete-if-not (test sequence &rest key-args) + (declare (dynamic-extent key-args)) + (apply 'delete-if (complement test) sequence key-args)) + (defun remove-duplicates (sequence &key (test 'eql) (key 'identity) (start 0) end test-not from-end) (when test-not (setf test (complement test-not))) @@ -1575,6 +1579,27 @@ (if (eq list-1 (cdr head)) (return list-1)))))) +(defun make-sequence (result-type size &key (initial-element nil initial-element-p)) + "=> sequence" + (ecase result-type + (string + (if (not initial-element-p) + (make-string size) + (make-string size :initial-element initial-element))) + (list + (make-list size :initial-element initial-element)))) - +(defun concatenate (result-type &rest sequences) + "=> result-sequence" + (declare (dynamic-extent sequences)) + (cond + ((null sequences) + (make-sequence result-type 0)) + ((and (null (rest sequences)) + (typep (first sequences) result-type)) + (copy-seq (first sequences))) + ((= 0 (length (first sequences))) + (apply #'concatenate result-type (cdr sequences))) + (t (error "Can't concatenate ~S yet: ~:S" result-type sequences)))) + From ffjeld at common-lisp.net Thu Jun 10 13:31:14 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 10 Jun 2004 06:31:14 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12671 Modified Files: integers.lisp Log Message: Added logior for (positive) bignums. Date: Thu Jun 10 06:31:14 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.35 movitz/losp/muerte/integers.lisp:1.36 --- movitz/losp/muerte/integers.lisp:1.35 Wed Jun 9 19:13:19 2004 +++ movitz/losp/muerte/integers.lisp Thu Jun 10 06:31:14 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.35 2004/06/10 02:13:19 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.36 2004/06/10 13:31:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1459,28 +1459,59 @@ (:notl :ecx) (:andl :ecx :eax))))) -(defun logior%2op (x y) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) x) - (:compile-form (:result-mode :ebx) y) - (:testb #.movitz::+movitz-fixnum-zmask+ :al) - (:jnz '(:sub-program () (:int 107))) - (:testb #.movitz::+movitz-fixnum-zmask+ :bl) - (:jnz '(:sub-program () (:movl :ebx :eax) (:int 107))) - (:orl :ebx :eax))) - - -(define-compiler-macro logior%2op (&whole form x y) - (cond - ((and (movitz:movitz-constantp x) (movitz:movitz-constantp y)) - (logior (movitz::movitz-eval x) (movitz::movitz-eval y))) - (t form))) - (defun logior (&rest integers) - (declare (dynamic-extent integers)) - (if (null integers) - 0 - (reduce #'logior%2op integers))) + (numargs-case + (1 (x) x) + (2 (x y) + (number-double-dispatch (x y) + ((fixnum fixnum) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) x y) + (:orl :ebx :eax))) + ((positive-fixnum positive-bignum) + (macrolet + ((do-it () + `(let ((r (copy-bignum y))) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ecx) r x) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:orl :ecx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))))) + (do-it))) + ((positive-bignum positive-fixnum) + (macrolet + ((do-it () + `(let ((r (copy-bignum x))) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ecx) r y) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:orl :ecx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))))) + (do-it))) + ((positive-bignum positive-bignum) + (if (< (%bignum-bigits x) (%bignum-bigits y)) + (logior y x) + (let ((r (copy-bignum x))) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) r y) + (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) + :ecx) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) + ,(* -1 movitz:+movitz-fixnum-factor+)) + :edx) ; EDX is loop counter + or-loop + (:movl (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) + :ecx) + (:orl :ecx + (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + (:subl 4 :edx) + (:jnc 'or-loop)))) + (do-it))))))) + (t (&rest integers) + (declare (dynamic-extent integers)) + (if (null integers) + 0 + (reduce #'logior integers))))) (define-compiler-macro logior (&whole form &rest integers) (let ((constant-folded-integers (loop for x in integers @@ -1496,8 +1527,8 @@ (case (length constant-folded-integers) (0 0) (1 (first constant-folded-integers)) - (2 `(logior%2op ,(first constant-folded-integers) ,(second constant-folded-integers))) - (t `(logior (logior%2op ,(first constant-folded-integers) ,(second constant-folded-integers)) + (2 `(no-macro-call logior ,(first constant-folded-integers) ,(second constant-folded-integers))) + (t `(logior (logior ,(first constant-folded-integers) ,(second constant-folded-integers)) ,@(cddr constant-folded-integers)))))) (defun logxor (&rest integers) @@ -1535,7 +1566,6 @@ (:cmpl ,(* (1- movitz:+movitz-fixnum-bits+) movitz:+movitz-fixnum-factor+) :ecx) (:ja '(:sub-program (outside-fixnum) - (:break) (:addl #x80000000 :eax) ; sign into carry (:sbbl :ecx :ecx) (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax) From ffjeld at common-lisp.net Thu Jun 10 13:51:24 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 10 Jun 2004 06:51:24 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7737 Modified Files: sequences.lisp Log Message: Somewhat improved concatenate, for (eq result-type 'vector). Date: Thu Jun 10 06:51:24 2004 Author: ffjeld Index: movitz/losp/muerte/sequences.lisp diff -u movitz/losp/muerte/sequences.lisp:1.9 movitz/losp/muerte/sequences.lisp:1.10 --- movitz/losp/muerte/sequences.lisp:1.9 Thu Jun 10 05:21:11 2004 +++ movitz/losp/muerte/sequences.lisp Thu Jun 10 06:51:24 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.9 2004/06/10 12:21:11 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.10 2004/06/10 13:51:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1600,6 +1600,15 @@ (copy-seq (first sequences))) ((= 0 (length (first sequences))) (apply #'concatenate result-type (cdr sequences))) + ((eq result-type 'vector) + (let* ((r (make-array (let ((length 0)) + (dolist (s sequences length) + (incf length (length s)))))) + (i 0)) + (dolist (s sequences) + (replace r s :start1 i) + (incf i (length s))) + r)) (t (error "Can't concatenate ~S yet: ~:S" result-type sequences)))) From ffjeld at common-lisp.net Thu Jun 10 13:51:53 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 10 Jun 2004 06:51:53 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7988 Modified Files: typep.lisp Log Message: Added vectorp. Date: Thu Jun 10 06:51:53 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.16 movitz/losp/muerte/typep.lisp:1.17 --- movitz/losp/muerte/typep.lisp:1.16 Wed Jun 9 16:05:34 2004 +++ movitz/losp/muerte/typep.lisp Thu Jun 10 06:51:53 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.16 2004/06/09 23:05:34 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.17 2004/06/10 13:51:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -467,6 +467,9 @@ (define-simple-typep (cons consp) (obj) (typep obj 'cons)) + +(define-simple-typep (vector vectorp) (obj) + (typep obj 'vector)) (define-simple-typep (pointer pointerp) (obj) (typep obj 'pointer)) From ffjeld at common-lisp.net Thu Jun 10 15:06:52 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 10 Jun 2004 08:06:52 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv11860 Modified Files: debugger.lisp Log Message: Fixed a stupid bug in match-code-pattern. Date: Thu Jun 10 08:06:52 2004 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.11 movitz/losp/x86-pc/debugger.lisp:1.12 --- movitz/losp/x86-pc/debugger.lisp:1.11 Wed Jun 2 07:31:20 2004 +++ movitz/losp/x86-pc/debugger.lisp Thu Jun 10 08:06:52 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.11 2004/06/02 14:31:20 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.12 2004/06/10 15:06:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -177,7 +177,7 @@ (setf result-register (second p) result-position (third p))) (:or - (dolist (sub-pattern (cdr p) (return nil)) + (dolist (sub-pattern (cdr p)) (multiple-value-bind (success-p sub-result-register sub-result-position new-ip) (match-code-pattern sub-pattern code-vector ip register) (when success-p @@ -185,7 +185,8 @@ (setf result-register sub-result-register result-position sub-result-position)) (setf ip new-ip) - (return))))) + (return)))) + (return nil)) (:* (let ((max-times (second p)) ; (:kleene-star ) (sub-pattern (third p))) (dotimes (i max-times) @@ -484,11 +485,11 @@ (function (let ((delta (code-vector-offset (funobj-code-vector funobj) eip))) (if delta - (format t "{Interrupt ~D in ~W at PC offset ~D." + (format t "{Exception ~D in ~W at PC offset ~D." exception (funobj-name funobj) delta) - (format t "{Interrupt ~D in ~W at EIP=#x~X. [#x~X]}" + (format t "{Exception ~D in ~W at EIP=#x~X. [#x~X]}" exception (funobj-name funobj) eip interrupt-frame)))) - (t (format t "{Interrupt ~D with ESI=#x~Z and EIP=#x~X. [#x~X]}" + (t (format t "{Exception ~D with ESI=#x~Z and EIP=#x~X. [#x~X]}" exception funobj eip interrupt-frame)))))))) (function (let ((name (funobj-name funobj))) From ffjeld at common-lisp.net Thu Jun 10 16:28:27 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 10 Jun 2004 09:28:27 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv2124 Modified Files: debugger.lisp Log Message: match-code-pattern still wasn't quite right. This should do it. Date: Thu Jun 10 09:28:27 2004 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.12 movitz/losp/x86-pc/debugger.lisp:1.13 --- movitz/losp/x86-pc/debugger.lisp:1.12 Thu Jun 10 08:06:52 2004 +++ movitz/losp/x86-pc/debugger.lisp Thu Jun 10 09:28:27 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.12 2004/06/10 15:06:52 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.13 2004/06/10 16:28:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -177,7 +177,7 @@ (setf result-register (second p) result-position (third p))) (:or - (dolist (sub-pattern (cdr p)) + (dolist (sub-pattern (cdr p) (return-from match-code-pattern nil)) (multiple-value-bind (success-p sub-result-register sub-result-position new-ip) (match-code-pattern sub-pattern code-vector ip register) (when success-p @@ -185,8 +185,7 @@ (setf result-register sub-result-register result-position sub-result-position)) (setf ip new-ip) - (return)))) - (return nil)) + (return))))) (:* (let ((max-times (second p)) ; (:kleene-star ) (sub-pattern (third p))) (dotimes (i max-times) From ffjeld at common-lisp.net Thu Jun 10 16:28:55 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 10 Jun 2004 09:28:55 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2326 Modified Files: sequences.lisp Log Message: Slightly better make-sequence and concatenate. Date: Thu Jun 10 09:28:55 2004 Author: ffjeld Index: movitz/losp/muerte/sequences.lisp diff -u movitz/losp/muerte/sequences.lisp:1.10 movitz/losp/muerte/sequences.lisp:1.11 --- movitz/losp/muerte/sequences.lisp:1.10 Thu Jun 10 06:51:24 2004 +++ movitz/losp/muerte/sequences.lisp Thu Jun 10 09:28:55 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.10 2004/06/10 13:51:24 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.11 2004/06/10 16:28:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1586,6 +1586,8 @@ (if (not initial-element-p) (make-string size) (make-string size :initial-element initial-element))) + (vector + (make-array size :initial-element initial-element)) (list (make-list size :initial-element initial-element)))) @@ -1600,10 +1602,11 @@ (copy-seq (first sequences))) ((= 0 (length (first sequences))) (apply #'concatenate result-type (cdr sequences))) - ((eq result-type 'vector) - (let* ((r (make-array (let ((length 0)) - (dolist (s sequences length) - (incf length (length s)))))) + ((member result-type '(vector string)) + (let* ((r (make-sequence result-type + (let ((length 0)) + (dolist (s sequences length) + (incf length (length s)))))) (i 0)) (dolist (s sequences) (replace r s :start1 i) From ffjeld at common-lisp.net Thu Jun 10 19:25:05 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 10 Jun 2004 12:25:05 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10428 Modified Files: integers.lisp Log Message: Added a really stupid /, and a slightly improved logxor. Date: Thu Jun 10 12:25:05 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.36 movitz/losp/muerte/integers.lisp:1.37 --- movitz/losp/muerte/integers.lisp:1.36 Thu Jun 10 06:31:14 2004 +++ movitz/losp/muerte/integers.lisp Thu Jun 10 12:25: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.36 2004/06/10 13:31:14 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.37 2004/06/10 19:25:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1277,6 +1277,19 @@ (do-it))) )))) +(defun / (number &rest denominators) + (declare (dynamic-extent denominators)) + (cond + ((null denominators) + (make-ratio 1 number)) + ((null (cdr denominators)) + (multiple-value-bind (q r) + (truncate number (first denominators)) + (if (= 0 r) + q + (error "Don't know how to divide ~S by ~S." number (first denominators))))) + (t (reduce '/ denominators :initial-value number)))) + (defun round (number &optional (divisor 1)) "Mathematical rounding." (multiple-value-bind (quotient remainder) @@ -1536,11 +1549,14 @@ (1 (x) x) (2 (x y) (number-double-dispatch (x y) + (((eql 0) t) y) + ((t (eql 0)) x) ((fixnum fixnum) (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) x) - (:compile-form (:result-mode :ebx) y) - (:xorl :ebx :eax))))) + (:compile-form (:result-mode :ecx) y) + ;; (:orl #.movitz:+movitz-fixnum-zmask+ :ecx) + (:xorl :ecx :eax))))) (t (&rest integers) (declare (dynamic-extent integers)) (if (null integers) From ffjeld at common-lisp.net Thu Jun 10 19:26:33 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 10 Jun 2004 12:26:33 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12124 Modified Files: functions.lisp Log Message: (setf funobj-constant-ref) had a nasty bug wrt. jumpers: The jumper would be off-by-2, causing very 'interesting' effects. Date: Thu Jun 10 12:26:33 2004 Author: ffjeld Index: movitz/losp/muerte/functions.lisp diff -u movitz/losp/muerte/functions.lisp:1.12 movitz/losp/muerte/functions.lisp:1.13 --- movitz/losp/muerte/functions.lisp:1.12 Thu Jun 10 05:09:15 2004 +++ movitz/losp/muerte/functions.lisp Thu Jun 10 12:26:33 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 12 22:58:54 2002 ;;;; -;;;; $Id: functions.lisp,v 1.12 2004/06/10 12:09:15 ffjeld Exp $ +;;;; $Id: functions.lisp,v 1.13 2004/06/10 19:26:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -312,16 +312,16 @@ (assert (below value (length (funobj-code-vector funobj))) (value) "The jumper value ~D is invalid because the code-vector's size is ~D." value (length (funobj-code-vector funobj))) - (progn ;; without-gc + (progn ;; XXX without-gc (with-inline-assembly (:returns :nothing) - (:compile-two-forms (:eax :ecx) funobj index) - (:leal (:ecx :eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0)) - :ebx) ; dest. address into ebx. - (:compile-form (:result-mode :untagged-fixnum-ecx) value) + (:compile-two-forms (:eax :edx) funobj index) + (:compile-form (:result-mode :ecx) value) + (:movl #.movitz:+code-vector-transient-word+ :ebx) (:addl (:eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) - :ecx) - (:movl :ecx (:ebx)) - (:xorl :ebx :ebx))) + :ebx) ; code-vector (word) into ebx + (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) ; value + (:movl :ecx (:eax :edx #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0))) + (:addl :ebx (:eax :edx #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0))))) value))) (defun funobj-debug-info (funobj) From ffjeld at common-lisp.net Thu Jun 10 19:27:37 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 10 Jun 2004 12:27:37 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12745 Modified Files: more-macros.lisp Log Message: Changed dolist a bit. Date: Thu Jun 10 12:27:36 2004 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.10 movitz/losp/muerte/more-macros.lisp:1.11 --- movitz/losp/muerte/more-macros.lisp:1.10 Wed Jun 9 16:04:26 2004 +++ movitz/losp/muerte/more-macros.lisp Thu Jun 10 12:27:36 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.10 2004/06/09 23:04:26 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.11 2004/06/10 19:27:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -129,15 +129,11 @@ , at declarations-and-body))) (defmacro dolist ((var list-form &optional result-form) &body declarations-and-body) - (let ((cons-var (gensym (format nil "dolist-cons-var-~A-" var))) - (loop-tag (gensym "dolist-loop-tag-"))) - `(prog ((,cons-var ,list-form)) - ,loop-tag - (when ,cons-var - (let ((,var (pop ,cons-var))) - , at declarations-and-body) - (go ,loop-tag)) - ,(when result-form `(return ,result-form))))) + (let ((cons-var (gensym "dolist-cons-"))) + `(do ((,cons-var ,list-form)) + ((null ,cons-var) ,result-form) + (let ((,var (pop ,cons-var))) + , at declarations-and-body)))) (defmacro letf* (bindings &body body &environment env) "Does what one might expect, saving the old values and setting the generalized @@ -315,8 +311,7 @@ (define-compiler-macro %bignum-bigits (x) `(with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) ,x) - (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum - 'movitz::length)) + (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax))) From ffjeld at common-lisp.net Thu Jun 10 19:28:19 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 10 Jun 2004 12:28:19 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13169 Modified Files: primitive-functions.lisp Log Message: Added some defensive checks in dynamic-load. Date: Thu Jun 10 12:28:19 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.21 movitz/losp/muerte/primitive-functions.lisp:1.22 --- movitz/losp/muerte/primitive-functions.lisp:1.21 Thu Jun 10 05:19:47 2004 +++ movitz/losp/muerte/primitive-functions.lisp Thu Jun 10 12:28:19 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.21 2004/06/10 12:19:47 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.22 2004/06/10 19:28:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -240,11 +240,15 @@ (with-inline-assembly (:returns :multiple-values) (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx)) (:jecxz 'no-stack-binding) + ;; Be defensive: Verify that ECX is within stack. + (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx)) (:cmpl :eax (:ecx)) (:je 'success) search-loop (:movl (:ecx 12) :ecx) ; parent (:jecxz 'no-stack-binding) + ;; Be defensive: Verify that ECX is within stack. + (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx)) (:cmpl :eax (:ecx)) ; compare name (:jne 'search-loop) ;; fall through on success From ffjeld at common-lisp.net Thu Jun 10 19:29:45 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 10 Jun 2004 12:29:45 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv14950 Modified Files: scavenge.lisp Log Message: Added support for bignums in map-heap-words. So now you can GC all those bigguns. Date: Thu Jun 10 12:29:45 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.8 movitz/losp/muerte/scavenge.lisp:1.9 --- movitz/losp/muerte/scavenge.lisp:1.8 Wed Jun 2 07:31:15 2004 +++ movitz/losp/muerte/scavenge.lisp Thu Jun 10 12:29:45 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.8 2004/06/02 14:31:15 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.9 2004/06/10 19:29:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -52,6 +52,12 @@ ((typep x '(or null fixnum character))) ((scavenge-typep x :illegal) (error "Illegal word ~Z at ~S." x scan)) + ((scavenge-typep x :bignum) + ;; Just skip the bigits + (let* ((bigits (memref scan 2 0 :unsigned-byte16)) + (size (+ 2 (logand bigits -2)))) + (assert (and (plusp bigits) (evenp size))) + (incf scan size))) ((scavenge-typep x :funobj) ;; Process code-vector pointer specially.. (let* ((funobj (%word-offset scan #.(movitz:tag :other))) @@ -68,7 +74,7 @@ )) (incf scan (+ 7 num-jumpers)))) ; Don't scan the jumpers. ((scavenge-typep x :infant-object) - (error "Scanning an infant object ~Z at ~S." x scan)) + (error "Scanning an infant object ~Z at ~S (end ~S)." x scan end-location)) ((or (scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u8)) (scavenge-wide-typep x :vector @@ -140,37 +146,57 @@ (values)) (defparameter *primitive-funcall-patterns* - '(#xff #x57 (:function-offset :signed8))) + '((:or + (#xff #x57 (:function-offset :signed8)) ; + (#xff #x97 (:function-offset :signed32))))) ; (defun stack-frame-primitive-funcall (funobj stack-location eip-location) + "Is stack-frame in a primitive-function? +If so, return the primitive-function's code-vector." (let ((return-address (memref stack-location 0 0 :unsigned-byte32)) (code-vector (funobj-code-vector funobj))) (multiple-value-bind (return-location return-delta) (truncate return-address #.movitz:+movitz-fixnum-factor+) (if (not (location-in-object-p code-vector return-location)) - nil - (multiple-value-bind (success-p type code) - (match-code-pattern *primitive-funcall-patterns* - code-vector (+ (* (- return-location - (object-location code-vector)) - #.movitz:+movitz-fixnum-factor+) - return-delta - -3 -8) - :function-offset) - (if (not success-p) - (warn "mismatch in ~S at ~D from #x~X in ~Z." - funobj - (+ (* (- return-location - (object-location code-vector)) - #.movitz:+movitz-fixnum-factor+) - return-delta - -3 -8) - return-address code-vector) - (let* ((offset (ecase type - (:signed8 - (if (not (logbitp 7 code)) code (- code 256))))) - (primitive-function (%word-offset (%run-time-context-ref offset) -2))) - (check-type primitive-function vector-u8) - (if (not (location-in-object-p primitive-function eip-location)) - nil - primitive-function)))))))) + nil ; A PF must have return-address on top of stack. + (dotimes (offset 5 (warn "mismatch in ~S at ~D from #x~X in ~Z." + funobj + (+ (* (- return-location + (object-location code-vector)) + #.movitz:+movitz-fixnum-factor+) + return-delta + -3 -8) + return-address code-vector)) + (multiple-value-bind (success-p type code ip) + (match-code-pattern *primitive-funcall-patterns* + code-vector (+ (* (- return-location + (object-location code-vector)) + #.movitz:+movitz-fixnum-factor+) + return-delta + -3 -8 (- offset)) + :function-offset) + (when success-p + (return + (let* ((offset (case type + (:signed8 + (if (not (logbitp 7 code)) code (- code 256))) + (:signed32 + ;; We must read the unsigned-byte32 that starts at ip + (let ((x (logior (aref code-vector (- ip 1)) + (* (aref code-vector (+ 0 ip)) #x100) + (* (aref code-vector (+ 1 ip)) #x10000) + (* (aref code-vector (+ 2 ip)) #x1000000)))) + (if (not (logbitp 7 (aref code-vector (+ ip 2)))) + x + (break "Negative 32-bit offset.")))) + (t (break "Match fail: vec: ~Z, ip: ~D" + code-vector (+ (* (- return-location + (object-location code-vector)) + #.movitz:+movitz-fixnum-factor+) + return-delta + -3 -8))))) + (primitive-function (%word-offset (%run-time-context-ref offset) -2))) + (check-type primitive-function vector-u8) + (if (not (location-in-object-p primitive-function eip-location)) + nil + primitive-function)))))))))) From ffjeld at common-lisp.net Thu Jun 10 19:30:19 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 10 Jun 2004 12:30:19 -0700 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv16752 Modified Files: compiler.lisp Log Message: Added compiler variable *compiler-produce-defensive-code*. Date: Thu Jun 10 12:30:19 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.67 movitz/compiler.lisp:1.68 --- movitz/compiler.lisp:1.67 Thu Jun 10 05:05:56 2004 +++ movitz/compiler.lisp Thu Jun 10 12:30:19 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.67 2004/06/10 12:05:56 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.68 2004/06/10 19:30:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -60,6 +60,9 @@ (defvar *compiler-do-type-inference* t "Spend time and effort performing type inference and optimization.") +(defvar *compiler-produce-defensive-code* t + "Try make code be extra cautious.") + (defvar *compiling-function-name*) (defvar muerte.cl:*compile-file-pathname* nil) @@ -68,6 +71,7 @@ (defvar *extended-code-find-write-binding-and-type* (make-hash-table :test #'eq)) + (defconstant +enter-stack-frame-code+ '((:pushl :ebp) From ffjeld at common-lisp.net Thu Jun 10 19:31:06 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 10 Jun 2004 12:31:06 -0700 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv18655 Modified Files: image.lisp Log Message: Added a scratch register to the run-time-context. Why didn't I do this before? Date: Thu Jun 10 12:31:06 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.38 movitz/image.lisp:1.39 --- movitz/image.lisp:1.38 Wed Jun 9 10:25:03 2004 +++ movitz/image.lisp Thu Jun 10 12:31:06 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.38 2004/06/09 17:25:03 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.39 2004/06/10 19:31:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -17,16 +17,16 @@ (define-binary-class movitz-constant-block (movitz-heap-object) ((constant-block-start :binary-type :label) ; keep this at the top. - (name - :binary-type word - :initform :global - :map-binary-write 'movitz-read-and-intern - :map-binary-read-delayed 'movitz-word) (type :binary-type other-type-byte :initform :run-time-context) (padding :binary-type 3) + (name + :binary-type word + :initform :global + :map-binary-write 'movitz-read-and-intern + :map-binary-read-delayed 'movitz-word) (fast-car :binary-type code-vector-word :initform nil @@ -485,7 +485,9 @@ (bochs-flags :binary-type lu32 :initform 0) - ) + (scratch0 ; A non-GC-root scratch register + :binary-type lu32 + :initform 0)) (:slot-align null-cons -1)) (defun atomically-status-simple-pf (pf-name reset-status-p &rest registers) From ffjeld at common-lisp.net Fri Jun 11 21:34:02 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 11 Jun 2004 14:34:02 -0700 Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv5428 Modified Files: special-operators-cl.lisp Log Message: Produce some extra defensive code at catch targets. Date: Fri Jun 11 14:34:02 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.18 movitz/special-operators-cl.lisp:1.19 --- movitz/special-operators-cl.lisp:1.18 Wed Jun 9 10:26:07 2004 +++ movitz/special-operators-cl.lisp Fri Jun 11 14:34:02 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.18 2004/06/09 17:26:07 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.19 2004/06/11 21:34:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1165,8 +1165,13 @@ body-code `((:popl :ebp) ; This value is identical to current EBP. ,exit-point - (:leal (:esp ,(+ -8 16)) :esp) - (:locally (:popl (:edi (:edi-offset dynamic-env))))))))) + (:leal (:esp ,(+ -8 16)) :esp)) + (if (not *compiler-produce-defensive-code*) + `((:locally (:popl (:edi (:edi-offset dynamic-env))))) + `((:xchgl :ecx (:esp)) + (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx)) + (:locally (:movl :ecx (:edi (:edi-offset dynamic-env)))) + (:popl :ecx))))))) (define-special-operator unwind-protect (&all all &form form &env env) (destructuring-bind (protected-form &body cleanup-forms) From ffjeld at common-lisp.net Fri Jun 11 23:26:09 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 11 Jun 2004 16:26:09 -0700 Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv17656 Modified Files: storage-types.lisp Log Message: Rearranged vector objects a bit. Changed map-heap-words accordingly. Also fixed some serious bugs in map-heap-words. Date: Fri Jun 11 16:26:09 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.19 movitz/storage-types.lisp:1.20 --- movitz/storage-types.lisp:1.19 Wed Jun 9 10:19:24 2004 +++ movitz/storage-types.lisp Fri Jun 11 16:26:09 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.19 2004/06/09 17:19:24 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.20 2004/06/11 23:26:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -342,10 +342,10 @@ :bit 5) :initarg :element-type :reader movitz-vector-element-type) - (fill-pointer + (num-elements :binary-type lu16 - :initarg :fill-pointer - :accessor movitz-vector-fill-pointer) + :initarg :num-elements + :reader movitz-vector-num-elements) (flags :accessor movitz-vector-flags :initarg :flags @@ -359,10 +359,10 @@ :initform 0 :initarg :alignment-power :reader movitz-vector-alignment-power) - (num-elements + (fill-pointer :binary-type lu16 - :initarg :num-elements - :reader movitz-vector-num-elements) + :initarg :fill-pointer + :accessor movitz-vector-fill-pointer) (data :binary-lisp-type :label) ; data follows physically here (symbolic-data From ffjeld at common-lisp.net Fri Jun 11 23:26:14 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 11 Jun 2004 16:26:14 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv17833 Modified Files: scavenge.lisp Log Message: Rearranged vector objects a bit. Changed map-heap-words accordingly. Also fixed some serious bugs in map-heap-words. Date: Fri Jun 11 16:26:14 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.9 movitz/losp/muerte/scavenge.lisp:1.10 --- movitz/losp/muerte/scavenge.lisp:1.9 Thu Jun 10 12:29:45 2004 +++ movitz/losp/muerte/scavenge.lisp Fri Jun 11 16:26:14 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.9 2004/06/10 19:29:45 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.10 2004/06/11 23:26:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -42,7 +42,13 @@ (movitz:tag primary)))) `(with-inline-assembly (:returns :boolean-zf=1) (:compile-form (:result-mode :eax) ,x) - (:cmpw ,code :ax))))) + (:cmpw ,code :ax)))) + (word-upper16 (x) + "Consider x as a 32-bit integer, and return the upper 16 bits (as a fixnum)." + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) ,x) + (:andl #xffff0000 :eax) + (:shrl ,(- 16 movitz:+movitz-fixnum-shift+) :eax)))) (do ((scan start-location (1+ scan))) ((>= scan end-location)) (let (;; (*i* i) @@ -53,11 +59,11 @@ ((scavenge-typep x :illegal) (error "Illegal word ~Z at ~S." x scan)) ((scavenge-typep x :bignum) + (assert (evenp scan)) ;; Just skip the bigits - (let* ((bigits (memref scan 2 0 :unsigned-byte16)) - (size (+ 2 (logand bigits -2)))) - (assert (and (plusp bigits) (evenp size))) - (incf scan size))) + (let* ((bigits (word-upper16 x)) + (delta (1+ (logand bigits -2)))) + (incf scan delta))) ((scavenge-typep x :funobj) ;; Process code-vector pointer specially.. (let* ((funobj (%word-offset scan #.(movitz:tag :other))) @@ -79,14 +85,14 @@ #.(bt:enum-value 'movitz:movitz-vector-element-type :u8)) (scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :character))) - (let ((len (memref scan 2 0 :unsigned-byte16))) + (let ((len (word-upper16 x))) (incf scan (1+ (* 2 (truncate (+ 7 len) 8)))))) ((scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16)) - (let ((len (memref scan 2 0 :unsigned-byte16))) + (let ((len (word-upper16 x))) (incf scan (1+ (* 2 (truncate (+ 3 len) 4)))))) ((scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32)) - (let ((len (memref scan 2 0 :unsigned-byte16))) - (incf scan (1+ (* 2 (truncate (+ 1 len) 2)))))) + (let ((len (word-upper16 x))) + (incf scan (1+ (logand (1+ len) -2))))) ((eq x (fixnum-word 3)) (incf scan) (incf scan (memref scan 0 0 :lisp))) From ffjeld at common-lisp.net Fri Jun 11 23:26:38 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 11 Jun 2004 16:26:38 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18015 Modified Files: integers.lisp Log Message: Minor fix to logior compiler-macro. Date: Fri Jun 11 16:26:38 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.37 movitz/losp/muerte/integers.lisp:1.38 --- movitz/losp/muerte/integers.lisp:1.37 Thu Jun 10 12:25:05 2004 +++ movitz/losp/muerte/integers.lisp Fri Jun 11 16:26:38 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.37 2004/06/10 19:25:05 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.38 2004/06/11 23:26:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1526,13 +1526,13 @@ 0 (reduce #'logior integers))))) -(define-compiler-macro logior (&whole form &rest integers) +(define-compiler-macro logior (&whole form &rest integers &environment env) (let ((constant-folded-integers (loop for x in integers with folded-constant = 0 - if (and (movitz:movitz-constantp x) - (not (zerop (movitz::movitz-eval x)))) + if (and (movitz:movitz-constantp x env) + (not (zerop (movitz:movitz-eval x env)))) do (setf folded-constant - (logior folded-constant (movitz::movitz-eval x))) + (logior folded-constant (movitz:movitz-eval x env))) else collect x into non-constants finally (return (if (= 0 folded-constant) non-constants From ffjeld at common-lisp.net Mon Jun 14 19:40:42 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 14 Jun 2004 12:40:42 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5940 Modified Files: symbols.lisp Log Message: Changed copy-symbol to just copy the raw words. This is required for shallow-copying, especially during GC. Date: Mon Jun 14 12:40:42 2004 Author: ffjeld Index: movitz/losp/muerte/symbols.lisp diff -u movitz/losp/muerte/symbols.lisp:1.13 movitz/losp/muerte/symbols.lisp:1.14 --- movitz/losp/muerte/symbols.lisp:1.13 Wed Jun 9 10:21:01 2004 +++ movitz/losp/muerte/symbols.lisp Mon Jun 14 12:40:42 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 4 23:55:41 2001 ;;;; -;;;; $Id: symbols.lisp,v 1.13 2004/06/09 17:21:01 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.14 2004/06/14 19:40:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -141,10 +141,10 @@ (load-global-constant movitz::unbound-function)))))) (defun %create-symbol (name &optional (package nil) - (plist nil) - (value (load-global-constant unbound-value)) - (function (load-global-constant movitz::unbound-function)) - (flags 0)) + (plist nil) + (value (load-global-constant unbound-value)) + (function (load-global-constant movitz::unbound-function)) + (flags 0)) (eval-when (:compile-toplevel) (assert (= 1 (- (movitz:tag :symbol) (movitz:tag :other))))) (let ((symbol (%word-offset (malloc-clumps 3) 1))) @@ -170,12 +170,11 @@ (if (or (eq nil symbol) (not copy-properties)) (%create-symbol (symbol-name symbol)) - (%create-symbol (symbol-name symbol) - nil - (symbol-plist symbol) - (%unbounded-symbol-value symbol) - (%unbounded-symbol-function symbol) - (symbol-flags symbol)))) + (let ((x (%word-offset (malloc-clumps 3) 1))) + (dotimes (i 6) + (setf (memref x #.movitz:+other-type-offset+ i :lisp) + (memref symbol #.movitz:+other-type-offset+ i :lisp))) + x))) (defun symbol-flags (symbol) (etypecase symbol From ffjeld at common-lisp.net Wed Jun 16 07:35:52 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 16 Jun 2004 00:35:52 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24670 Modified Files: primitive-functions.lisp Log Message: Added function malloc-end. Date: Wed Jun 16 00:35:52 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.22 movitz/losp/muerte/primitive-functions.lisp:1.23 --- movitz/losp/muerte/primitive-functions.lisp:1.22 Thu Jun 10 12:28:19 2004 +++ movitz/losp/muerte/primitive-functions.lisp Wed Jun 16 00:35:52 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.22 2004/06/10 19:28:19 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.23 2004/06/16 07:35:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -472,6 +472,11 @@ (:jnz '(:sub-program () (:int 107))) (:shrl 1 :eax))) + +(defun malloc-end () + "Return the last location of the (dynamically allocated) heap area." + (+ (malloc-buffer-start) + (* 2 (malloc-cons-pointer)))) (define-primitive-function fast-cons () "Allocate a cons cell. Call with car in eax and cdr in ebx." From ffjeld at common-lisp.net Wed Jun 16 07:37:17 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 16 Jun 2004 00:37:17 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/eval.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27155 Modified Files: eval.lisp Log Message: Added when and unless. I really should add proper macros soon. Date: Wed Jun 16 00:37:17 2004 Author: ffjeld Index: movitz/losp/muerte/eval.lisp diff -u movitz/losp/muerte/eval.lisp:1.8 movitz/losp/muerte/eval.lisp:1.9 --- movitz/losp/muerte/eval.lisp:1.8 Fri Apr 23 06:00:30 2004 +++ movitz/losp/muerte/eval.lisp Wed Jun 16 00:37:17 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.8 2004/04/23 13:00:30 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.9 2004/06/16 07:37:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -72,6 +72,10 @@ (case (car form) (quote (cadr form)) (function (eval-function (second form) env)) + (when (when (eval-form (second form) env) + (eval-progn (cddr form) env))) + (unless (unless (eval-form (second form) env) + (eval-progn (cddr form) env))) (if (if (eval-form (second form) env) (eval-form (third form) env) (eval-form (fourth form) env))) From ffjeld at common-lisp.net Wed Jun 16 07:38:27 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 16 Jun 2004 00:38:27 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv29247 Modified Files: arrays.lisp Log Message: Aref should complain about the vector's (array-dimension v 0), not (length v). Date: Wed Jun 16 00:38:27 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.22 movitz/losp/muerte/arrays.lisp:1.23 --- movitz/losp/muerte/arrays.lisp:1.22 Mon May 24 14:51:52 2004 +++ movitz/losp/muerte/arrays.lisp Wed Jun 16 00:38:27 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.22 2004/05/24 21:51:52 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.23 2004/06/16 07:38:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -207,7 +207,8 @@ (:cmpw (:eax ,(bt:slot-offset 'movitz:movitz-vector 'movitz::num-elements)) :bx) (:jae '(:sub-program () (:compile-form (:result-mode :ignore) - (error "Index ~D out of bounds ~D." index (length vector))))) + (error "Index ~D out of bounds ~D." + index (array-dimension vector 0))))) (:cmpl ,(movitz:vector-type-tag :any-t) :ecx) (:jne 'not-any-t) From ffjeld at common-lisp.net Wed Jun 16 07:38:51 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 16 Jun 2004 00:38:51 -0700 Subject: [movitz-cvs] CVS update: movitz/packages.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29600 Modified Files: packages.lisp Log Message: Added a symbol. Date: Wed Jun 16 00:38:51 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.25 movitz/packages.lisp:1.26 --- movitz/packages.lisp:1.25 Tue Jun 8 13:07:02 2004 +++ movitz/packages.lisp Wed Jun 16 00:38:51 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.25 2004/06/08 20:07:02 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.26 2004/06/16 07:38:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1144,6 +1144,7 @@ #:malloc-data-clumps #:malloc-cons-pointer #:malloc-buffer-start + #:malloc-end #:%word-offset #:%run-time-context-slot From ffjeld at common-lisp.net Wed Jun 16 07:40:38 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 16 Jun 2004 00:40:38 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv3615 Modified Files: los0-gc.lisp Log Message: Various hacking and experimentation I did before the eurolisp-workshop. Date: Wed Jun 16 00:40:38 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.17 movitz/losp/los0-gc.lisp:1.18 --- movitz/losp/los0-gc.lisp:1.17 Sat Jun 5 20:02:08 2004 +++ movitz/losp/los0-gc.lisp Wed Jun 16 00:40:38 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.17 2004/06/06 03:02:08 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.18 2004/06/16 07:40:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -267,6 +267,10 @@ (+ (object-location space) (array-dimension space 0))))) +(defun tenure () + (install-old-consing) + (install-los0-consing)) + (defun report-nursery (x location) "Write a message if x is inside newspace." (when (object-in-space-p (%run-time-context-slot 'nursery-space) x) @@ -286,7 +290,21 @@ find-location x location)) x)) -(defun stop-and-copy () +(defun kill-the-newborns () + (let* ((oldspace (%run-time-context-slot 'nursery-space)) + (newspace (space-other oldspace))) + (setf (%run-time-context-slot 'nursery-space) newspace) + (flet ((zap-oldspace (x location) + (declare (ignore location)) + (if (object-in-space-p oldspace x) + nil + x))) + (map-heap-words #'zap-oldspace 0 (malloc-end)) + (map-stack-words #'zap-oldspace (current-stack-frame)) + (initialize-space oldspace) + (values)))) + +(defun stop-and-copy (&optional evacuator) (let* ((space0 (%run-time-context-slot 'nursery-space)) (space1 (space-other space0))) (check-type space0 vector-u32) @@ -299,29 +317,30 @@ (values space1 space0)) ;; Ensure newspace is activated. (setf (%run-time-context-slot 'nursery-space) newspace) - ;; (assert (< #x200 (- (length newspace) (space-fresh-pointer newspace)))) ;; Evacuate-oldspace is to be mapped over every potential pointer. - (flet ((evacuate-oldspace (x location) - "If x is in oldspace, migrate it to newspace." - (declare (ignore location)) - (if (not (object-in-space-p oldspace x)) - x - (let ((forwarded-x (memref (object-location x) 0 1 :lisp))) - (if (object-in-space-p newspace forwarded-x) - forwarded-x - (let ((forward-x (shallow-copy x))) - (setf (memref (object-location x) 0 1 :lisp) forward-x) - forward-x)))))) + (let ((evacuator + (or evacuator + (lambda (x location) + "If x is in oldspace, migrate it to newspace." + (declare (ignore location)) + (if (not (object-in-space-p oldspace x)) + x + (let ((forwarded-x (memref (object-location x) 0 1 :lisp))) + (if (object-in-space-p newspace forwarded-x) + forwarded-x + (let ((forward-x (shallow-copy x))) + (setf (memref (object-location x) 0 1 :lisp) forward-x) + forward-x)))))))) ;; Scavenge roots - (map-heap-words #'evacuate-oldspace 0 (+ (malloc-buffer-start) + (map-heap-words evacuator 0 (+ (malloc-buffer-start) (* 2 (malloc-cons-pointer)))) - (map-stack-words #'evacuate-oldspace (current-stack-frame)) + (map-stack-words evacuator (current-stack-frame)) ;; Scan newspace, Cheney style. (loop with newspace-location = (+ 2 (object-location newspace)) with scan-pointer = 2 as fresh-pointer = (space-fresh-pointer newspace) while (< scan-pointer fresh-pointer) - do (map-heap-words #'evacuate-oldspace + do (map-heap-words evacuator (+ newspace-location scan-pointer) (+ newspace-location (space-fresh-pointer newspace))) (setf scan-pointer fresh-pointer)) From ffjeld at common-lisp.net Wed Jun 16 07:42:50 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 16 Jun 2004 00:42:50 -0700 Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv6037 Modified Files: storage-types.lisp Log Message: Changed the layout of vectors somewhat (this is a minor change, not the "proper" new layout that should come soon). This requires a re-compile of any images. And fixed some (somewhat related) bugs in the map-heap-words function. Date: Wed Jun 16 00:42:50 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.20 movitz/storage-types.lisp:1.21 --- movitz/storage-types.lisp:1.20 Fri Jun 11 16:26:09 2004 +++ movitz/storage-types.lisp Wed Jun 16 00:42:50 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.20 2004/06/11 23:26:09 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.21 2004/06/16 07:42:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -345,7 +345,7 @@ (num-elements :binary-type lu16 :initarg :num-elements - :reader movitz-vector-num-elements) + :reader movitz-vector-num-elements) (flags :accessor movitz-vector-flags :initarg :flags @@ -362,7 +362,7 @@ (fill-pointer :binary-type lu16 :initarg :fill-pointer - :accessor movitz-vector-fill-pointer) + :accessor movitz-vector-fill-pointer) (data :binary-lisp-type :label) ; data follows physically here (symbolic-data @@ -375,31 +375,51 @@ (byte 8 8) (enum-value 'other-type-byte :vector))) -;;;(define-binary-class movitz-new-vector (movitz-heap-object-other) -;;; ((length -;;; :binary-type u32 -;;; :initarg :length -;;; :accessor movitz-simple-vector-length) -;;; (type -;;; :binary-type other-type-byte -;;; :reader movitz-vector-type) -;;; #+ignore -;;; (element-type -;;; :binary-type (define-enum movitz-vector-element-type (u8) -;;; :any-t 0 -;;; :character 1 -;;; :u8 2 -;;; :u16 3 -;;; :u32 4 -;;; :bit 5) -;;; :initarg :element-type -;;; :reader movitz-vector-element-type) -;;; (data -;;; :binary-lisp-type :label) -;;; (symbolic-data -;;; :initarg :symbolic-data -;;; :accessor movitz-vector-symbolic-data)) -;;; (:slot-align type #.+other-type-offset+)) +#+ignore +(define-binary-class movitz-new-vector (movitz-heap-object-other) + ((type + :binary-type other-type-byte + :reader movitz-vector-type + :initform :new-vector) + (element-type + :binary-type (define-enum movitz-vector-element-type (u8) + :any-t 0 + :character 1 + :u8 2 + :u16 3 + :u32 4 + :bit 5) + :initarg :element-type + :reader movitz-vector-element-type) + (dummy + :binary-type :lu16) + (fill-pointer + :binary-type lu16 + :initarg :fill-pointer + :accessor movitz-vector-fill-pointer) + (flags + :accessor movitz-vector-flags + :initarg :flags + :initform nil + :binary-type (define-bitfield movitz-vector-flags (u8) + (((:bits) :fill-pointer-p 2 + :code-vector-p 3 + :std-instance-slots-p 4)))) + (alignment-power + :binary-lisp-type u8 ; align to 2^(high-nibble+3) + low-nibble + :initform 0 + :initarg :alignment-power + :reader movitz-vector-alignment-power) + (num-elements + :binary-type lu16 + :initarg :num-elements + :reader movitz-vector-num-elements) + (data + :binary-lisp-type :label) ; data follows physically here + (symbolic-data + :initarg :symbolic-data + :accessor movitz-vector-symbolic-data)) + (:slot-align type #.+other-type-offset+)) (defun movitz-type-word-size (type) (truncate (sizeof (intern (symbol-name type) :movitz)) 4)) From ffjeld at common-lisp.net Wed Jun 16 07:42:55 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 16 Jun 2004 00:42:55 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6136 Modified Files: scavenge.lisp Log Message: Changed the layout of vectors somewhat (this is a minor change, not the "proper" new layout that should come soon). This requires a re-compile of any images. And fixed some (somewhat related) bugs in the map-heap-words function. Date: Wed Jun 16 00:42:55 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.10 movitz/losp/muerte/scavenge.lisp:1.11 --- movitz/losp/muerte/scavenge.lisp:1.10 Fri Jun 11 16:26:14 2004 +++ movitz/losp/muerte/scavenge.lisp Wed Jun 16 00:42:55 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.10 2004/06/11 23:26:14 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.11 2004/06/16 07:42:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -59,12 +59,15 @@ ((scavenge-typep x :illegal) (error "Illegal word ~Z at ~S." x scan)) ((scavenge-typep x :bignum) - (assert (evenp scan)) + (assert (evenp scan) () + "Scanned #x~Z at odd address #x~X." x scan) ;; Just skip the bigits (let* ((bigits (word-upper16 x)) (delta (1+ (logand bigits -2)))) (incf scan delta))) ((scavenge-typep x :funobj) + (assert (evenp scan) () + "Scanned #x~Z at odd address #x~X." x scan) ;; Process code-vector pointer specially.. (let* ((funobj (%word-offset scan #.(movitz:tag :other))) (code-vector (funobj-code-vector funobj)) @@ -80,18 +83,26 @@ )) (incf scan (+ 7 num-jumpers)))) ; Don't scan the jumpers. ((scavenge-typep x :infant-object) + (assert (evenp scan) () + "Scanned #x~Z at odd address #x~X." x scan) (error "Scanning an infant object ~Z at ~S (end ~S)." x scan end-location)) ((or (scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u8)) (scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :character))) - (let ((len (word-upper16 x))) + (assert (evenp scan) () + "Scanned #x~Z at odd address #x~X." x scan) + (let ((len (memref scan (word-upper16 x) 0 :unsigned-byte16))) (incf scan (1+ (* 2 (truncate (+ 7 len) 8)))))) ((scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16)) - (let ((len (word-upper16 x))) + (assert (evenp scan) () + "Scanned #x~Z at odd address #x~X." x scan) + (let ((len (memref scan (word-upper16 x) 0 :unsigned-byte16))) (incf scan (1+ (* 2 (truncate (+ 3 len) 4)))))) ((scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32)) - (let ((len (word-upper16 x))) + (assert (evenp scan) () + "Scanned #x~Z at odd address #x~X." x scan) + (let ((len (memref scan (word-upper16 x) 0 :unsigned-byte16))) (incf scan (1+ (logand (1+ len) -2))))) ((eq x (fixnum-word 3)) (incf scan) From ffjeld at common-lisp.net Thu Jun 17 09:49:03 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 17 Jun 2004 02:49:03 -0700 Subject: [movitz-cvs] CVS update: movitz/packages.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv3551 Modified Files: packages.lisp Log Message: Starting to implement the new data-structure for vectors. Date: Thu Jun 17 02:49:03 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.26 movitz/packages.lisp:1.27 --- movitz/packages.lisp:1.26 Wed Jun 16 00:38:51 2004 +++ movitz/packages.lisp Thu Jun 17 02:49:03 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.26 2004/06/16 07:38:51 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.27 2004/06/17 09:49:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1327,10 +1327,12 @@ #:movitz-object-browser-properties #:movitz-heap-object + #:movitz-basic-vector #:movitz-vector #:movitz-vector-num-elements #:movitz-vector-element-type #:movitz-vector-symbolic-data + #:basic-vector-type-tag #:vector-type-tag #:movitz-symbol From ffjeld at common-lisp.net Thu Jun 17 09:49:08 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 17 Jun 2004 02:49:08 -0700 Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv3661 Modified Files: storage-types.lisp Log Message: Starting to implement the new data-structure for vectors. Date: Thu Jun 17 02:49:08 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.21 movitz/storage-types.lisp:1.22 --- movitz/storage-types.lisp:1.21 Wed Jun 16 00:42:50 2004 +++ movitz/storage-types.lisp Thu Jun 17 02:49:08 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.21 2004/06/16 07:42:50 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.22 2004/06/17 09:49:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -68,13 +68,14 @@ :symbol 7 :vector #x1a - :defstruct #x20 + :basic-vector #x22 :funobj #x3a + :bignum #x4a + :defstruct #x20 :std-instance #x40 :run-time-context #x50 :illegal #x13 :infant-object #x23 - :bignum #x4a ;; :simple-vector #x20 ;; :character-vector @@ -375,12 +376,16 @@ (byte 8 8) (enum-value 'other-type-byte :vector))) -#+ignore -(define-binary-class movitz-new-vector (movitz-heap-object-other) +(defun basic-vector-type-tag (element-type) + (dpb (enum-value 'movitz-vector-element-type element-type) + (byte 8 8) + (enum-value 'other-type-byte :basic-vector))) + +(define-binary-class movitz-basic-vector (movitz-heap-object-other) ((type :binary-type other-type-byte :reader movitz-vector-type - :initform :new-vector) + :initform :basic-vector) (element-type :binary-type (define-enum movitz-vector-element-type (u8) :any-t 0 @@ -391,27 +396,12 @@ :bit 5) :initarg :element-type :reader movitz-vector-element-type) - (dummy - :binary-type :lu16) (fill-pointer :binary-type lu16 :initarg :fill-pointer :accessor movitz-vector-fill-pointer) - (flags - :accessor movitz-vector-flags - :initarg :flags - :initform nil - :binary-type (define-bitfield movitz-vector-flags (u8) - (((:bits) :fill-pointer-p 2 - :code-vector-p 3 - :std-instance-slots-p 4)))) - (alignment-power - :binary-lisp-type u8 ; align to 2^(high-nibble+3) + low-nibble - :initform 0 - :initarg :alignment-power - :reader movitz-vector-alignment-power) (num-elements - :binary-type lu16 + :binary-type word :initarg :num-elements :reader movitz-vector-num-elements) (data From ffjeld at common-lisp.net Thu Jun 17 09:49:13 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 17 Jun 2004 02:49:13 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3732 Modified Files: arrays.lisp Log Message: Starting to implement the new data-structure for vectors. Date: Thu Jun 17 02:49:13 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.23 movitz/losp/muerte/arrays.lisp:1.24 --- movitz/losp/muerte/arrays.lisp:1.23 Wed Jun 16 00:38:27 2004 +++ movitz/losp/muerte/arrays.lisp Thu Jun 17 02:49:13 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.23 2004/06/16 07:38:27 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.24 2004/06/17 09:49:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -98,24 +98,66 @@ (defun vector-fill-pointer (vector) (vector-fill-pointer vector)) +(define-compiler-macro %basic-vector-has-fill-pointer-p (vector) + "Does the basic-vector have a fill-pointer?" + `(with-inline-assembly (:returns :boolean-zf=1) + (:compile-form (:result-mode :eax) ,vector) + (:testl ,(logxor #xffffffff (1- (expt 2 14))) + (:eax ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))))) + +(define-compiler-macro %basic-vector-fill-pointer (vector) + "Return the basic-vector's fill-pointer. The result is only valid if +%basic-vector-has-fill-pointer-p is true." + `(with-inline-assembly (:returns :register) + (:compile-form (:result-mode :register) ,vector) + (:movzxw ((:result-register) + ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)) + (:result-register)))) (defun array-has-fill-pointer-p (array) - (etypecase array ; + (etypecase array + (basic-vector + (%basic-vector-has-fill-pointer-p array)) (vector t) (array nil))) (defun fill-pointer (vector) - (check-type vector vector) - (memref vector #.(bt:slot-offset 'movitz:movitz-vector 'movitz::fill-pointer) 0 - :unsigned-byte16)) + (etypecase vector + (basic-vector + (assert (%basic-vector-has-fill-pointer-p vector) (vector) + "Vector has no fill-pointer.") + (%basic-vector-fill-pointer vector)) + (vector + (memref vector #.(bt:slot-offset 'movitz:movitz-vector 'movitz::fill-pointer) 0 + :unsigned-byte16)))) (defun (setf fill-pointer) (new-fill-pointer vector) - (check-type vector vector) - (assert (<= new-fill-pointer (vector-dimension vector))) - (setf (memref vector #.(bt:slot-offset 'movitz::movitz-vector 'movitz::fill-pointer) 0 - :unsigned-byte16) - new-fill-pointer)) + (etypecase vector + (basic-vector + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) new-fill-pointer vector) + (:testb ,movitz:+movitz-fixnum-zmask+ :al) + (:jnz 'illegal-fill-pointer) + (:movl (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)) + :ecx) + (:testl ,(logxor #xffffffff (1- (expt 2 14))) :ecx) + (:jnz '(:sub-program () + (:compile-form (:result-mode :ignore) + (error "Vector has no fill-pointer.")))) + (:cmpl :eax :ecx) + (:jc '(:sub-program (illegal-fill-pointer) + (:compile-form (:result-mode :ignore) + (error "Illegal fill-pointer: ~W." new-fill-pointer)))) + (:movw :ax (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)))))) + (do-it))) + (vector + (assert (<= new-fill-pointer (vector-dimension vector))) + (setf (memref vector #.(bt:slot-offset 'movitz::movitz-vector 'movitz::fill-pointer) 0 + :unsigned-byte16) + new-fill-pointer)))) (defun vector-aref%unsafe (vector index) "No type-checking of or ." @@ -571,6 +613,24 @@ (setf (aref array i) initial-element))) (initial-contents (replace array initial-contents))) + array)) + ((eq element-type :basic) + (check-type dimensions (and fixnum (integer 0 *))) + (let ((array (malloc-words dimensions))) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-new-vector 'movitz::num-elements) + 0 :lisp) + dimensions) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type) + 0 :unsigned-byte16) + #.(movitz:basic-vector-type-tag :any-t)) + (when fill-pointer + (setf (fill-pointer array) fill-pointer)) + (cond + (initial-contents + (replace array initial-contents)) + (initial-element + (dotimes (i dimensions) + (setf (svref%unsafe array i) initial-element)))) array)) (t (let ((array (malloc-words dimensions))) (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags) From ffjeld at common-lisp.net Thu Jun 17 09:49:18 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 17 Jun 2004 02:49:18 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3802 Modified Files: inspect.lisp Log Message: Starting to implement the new data-structure for vectors. Date: Thu Jun 17 02:49:18 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.11 movitz/losp/muerte/inspect.lisp:1.12 --- movitz/losp/muerte/inspect.lisp:1.11 Wed Jun 9 13:23:48 2004 +++ movitz/losp/muerte/inspect.lisp Thu Jun 17 02:49:18 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.11 2004/06/09 20:23:48 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.12 2004/06/17 09:49:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -211,6 +211,7 @@ (malloc-clumps clumps)) (defun malloc-words (words) + "Allocate space for at least (+ 2 words) cells/words." (malloc-clumps (1+ (truncate (1+ words) 2)))) (defun malloc-data-words (words) From ffjeld at common-lisp.net Thu Jun 17 09:49:23 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 17 Jun 2004 02:49:23 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3871 Modified Files: primitive-functions.lisp Log Message: Starting to implement the new data-structure for vectors. Date: Thu Jun 17 02:49:23 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.23 movitz/losp/muerte/primitive-functions.lisp:1.24 --- movitz/losp/muerte/primitive-functions.lisp:1.23 Wed Jun 16 00:35:52 2004 +++ movitz/losp/muerte/primitive-functions.lisp Thu Jun 17 02:49:23 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.23 2004/06/16 07:35:52 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.24 2004/06/17 09:49:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -658,6 +658,8 @@ (movitz-accessor object movitz-funobj-standard-gf standard-gf-class)) (string (find-class 'string)) + (basic-vector + (find-class 'vector)) (vector (find-class 'vector)) (function From ffjeld at common-lisp.net Thu Jun 17 09:49:29 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 17 Jun 2004 02:49:29 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3942 Modified Files: typep.lisp Log Message: Starting to implement the new data-structure for vectors. Date: Thu Jun 17 02:49:28 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.17 movitz/losp/muerte/typep.lisp:1.18 --- movitz/losp/muerte/typep.lisp:1.17 Thu Jun 10 06:51:53 2004 +++ movitz/losp/muerte/typep.lisp Thu Jun 17 02:49:28 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.17 2004/06/10 13:51:53 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.18 2004/06/17 09:49:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -233,6 +233,8 @@ (:cmpb ,(movitz:tag :character) :al))) ((function compiled-function) (make-other-typep :funobj)) + ((basic-vector) + (make-other-typep :basic-vector)) ((vector array) (make-other-typep :vector)) (simple-vector From ffjeld at common-lisp.net Thu Jun 17 19:44:40 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 17 Jun 2004 12:44:40 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13383 Modified Files: arrays.lisp Log Message: The new vector structure is called basic-vectors. This check-in adds some support for this structure. The plan is to add more-or-less complete support for the new structure, and then migrate everything to this, and then eventually remove the old structure "movitz-vector". Date: Thu Jun 17 12:44:39 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.24 movitz/losp/muerte/arrays.lisp:1.25 --- movitz/losp/muerte/arrays.lisp:1.24 Thu Jun 17 02:49:13 2004 +++ movitz/losp/muerte/arrays.lisp Thu Jun 17 12:44:39 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.24 2004/06/17 09:49:13 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.25 2004/06/17 19:44:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -71,18 +71,13 @@ (defun array-dimension (array axis-number) (etypecase array + (basic-vector + (assert (zerop axis-number)) + (movitz-accessor array movitz-basic-vector num-elements)) (vector (assert (zerop axis-number)) (vector-dimension array)))) -(define-compiler-macro array-dimension (&whole form array axis-number) - (cond - ((and (movitz:movitz-constantp axis-number) - (zerop (movitz::movitz-eval axis-number))) - `(vector-dimension ,array)) - (t (warn "Unknown array-dimension: ~S" form) - form))) - (defun shrink-vector (vector new-size) (set-movitz-accessor-u16 vector movitz-vector num-elements new-size) vector) @@ -111,7 +106,7 @@ `(with-inline-assembly (:returns :register) (:compile-form (:result-mode :register) ,vector) (:movzxw ((:result-register) - ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)) + ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::fill-pointer)) (:result-register)))) (defun array-has-fill-pointer-p (array) @@ -151,7 +146,7 @@ (:jc '(:sub-program (illegal-fill-pointer) (:compile-form (:result-mode :ignore) (error "Illegal fill-pointer: ~W." new-fill-pointer)))) - (:movw :ax (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)))))) + (:movw :ax (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::fill-pointer)))))) (do-it))) (vector (assert (<= new-fill-pointer (vector-dimension vector))) @@ -225,73 +220,111 @@ done)) -(defun aref (vector &rest subscripts) +(defun aref (array &rest subscripts) (numargs-case - (2 (vector index) - (macrolet - ((do-it () - `(with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) vector) - (:compile-form (:result-mode :ebx) index) - (:leal (:eax ,(- (movitz:tag :other))) :ecx) - (:testb ,movitz::+movitz-fixnum-zmask+ :bl) - (:jnz '(:sub-program (not-fixnum) (:int 107))) ; index not fixnum - (:andl ,(ash #x000ffff movitz:+movitz-fixnum-shift+) :ebx) - - (:testb 7 :cl) - (:jnz '(:sub-program () - (:compile-form (:result-mode :ignore) - (error "Not a vector: ~S" vector)))) + (2 (array index) + (etypecase array + (basic-vector + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:declare-label-set basic-vector-dispatcher + (any-t unknown unknown unknown + unknown unknown unknown unknown)) + (:compile-two-forms (:eax :ebx) array index) + (:movl (:eax ,movitz:+other-type-offset+) :ecx) + (:cmpb ,(movitz:tag :basic-vector) :cl) + (:jne '(:sub-program (not-vector) + (:compile-form (:result-mode :ignore) + (error "Not an array: ~S." array)))) + (:testb ,movitz:+movitz-fixnum-zmask+ :bl) + (:jnz '(:sub-program (illegal-index) + (:compile-form (:result-mode :ignore) + (error "Illegal index: ~S." index)))) + (:shrl 8 :ecx) + (:andl 7 :ecx) + (:jmp (:esi (:ecx 4) 'basic-vector-dispatcher + ,(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0))) + (() () '(:sub-program (unknown) (:int 100))) + any-t + (:cmpl :ebx + (:eax ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))) + (:jbe '(:sub-program (out-of-bounds) + (:compile-form (:result-mode :ignore) + (error "Index ~D is beyond vector length ~D." + index + (memref array + ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements) + 0 :lisp))))) + (:movl (:eax :ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)) + :eax)))) + (do-it))) + (old-vector + (let ((vector array)) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) vector) + (:compile-form (:result-mode :ebx) index) + (:leal (:eax ,(- (movitz:tag :other))) :ecx) + (:testb ,movitz::+movitz-fixnum-zmask+ :bl) + (:jnz '(:sub-program (not-fixnum) (:int 107))) ; index not fixnum + (:andl ,(ash #x000ffff movitz:+movitz-fixnum-shift+) :ebx) + + (:testb 7 :cl) + (:jnz '(:sub-program () + (:compile-form (:result-mode :ignore) + (error "Not a vector: ~S" vector)))) - (:shrl ,movitz:+movitz-fixnum-shift+ :ebx) - (:movzxw (:eax ,movitz:+other-type-offset+) :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ebx) + (:movzxw (:eax ,movitz:+other-type-offset+) :ecx) - (:cmpw (:eax ,(bt:slot-offset 'movitz:movitz-vector 'movitz::num-elements)) :bx) - (:jae '(:sub-program () - (:compile-form (:result-mode :ignore) - (error "Index ~D out of bounds ~D." - index (array-dimension vector 0))))) - - (:cmpl ,(movitz:vector-type-tag :any-t) :ecx) - (:jne 'not-any-t) - (:movl (:eax (:ebx 4) 2) :eax) - (:jmp 'done) + (:cmpw (:eax ,(bt:slot-offset 'movitz:movitz-vector 'movitz::num-elements)) :bx) + (:jae '(:sub-program () + (:compile-form (:result-mode :ignore) + (error "Index ~D out of bounds ~D." + index (array-dimension vector 0))))) + + (:cmpl ,(movitz:vector-type-tag :any-t) :ecx) + (:jne 'not-any-t) + (:movl (:eax (:ebx 4) 2) :eax) + (:jmp 'done) + + not-any-t + (:cmpl ,(movitz:vector-type-tag :character) :ecx) + (:jne 'not-character) + (:movb (:eax :ebx 2) :bl) + (:xorl :eax :eax) + (:movb :bl :ah) + (:movb ,(movitz::tag :character) :al) ; character + (:jmp 'done) + + not-character + (:cmpl ,(movitz:vector-type-tag :u8) :ecx) + (:jne 'not-u8) + (:movzxb (:eax :ebx 2) :eax) ; u8 + (:shll ,movitz::+movitz-fixnum-shift+ :eax) + (:jmp 'done) + + not-u8 + (:cmpl ,(movitz:vector-type-tag :u16) :ecx) + (:jne 'not-u16) + (:movzxw (:eax (:ebx 2) 2) :eax) ; u16 + (:jmp 'done) + + not-u16 + (:cmpl ,(movitz:vector-type-tag :u32) :ecx) + (:jne 'not-u32) + (:movl (:eax (:ebx 4) 2) :ecx) ; u32 + (:call-global-constant box-u32-ecx) + (:jmp 'done) + + not-u32 + (:compile-form (:result-mode :ignore) + (error "Not a vector: ~S" vector)) - not-any-t - (:cmpl ,(movitz:vector-type-tag :character) :ecx) - (:jne 'not-character) - (:movb (:eax :ebx 2) :bl) - (:xorl :eax :eax) - (:movb :bl :ah) - (:movb ,(movitz::tag :character) :al) ; character - (:jmp 'done) - - not-character - (:cmpl ,(movitz:vector-type-tag :u8) :ecx) - (:jne 'not-u8) - (:movzxb (:eax :ebx 2) :eax) ; u8 - (:shll ,movitz::+movitz-fixnum-shift+ :eax) - (:jmp 'done) - - not-u8 - (:cmpl ,(movitz:vector-type-tag :u16) :ecx) - (:jne 'not-u16) - (:movzxw (:eax (:ebx 2) 2) :eax) ; u16 - (:jmp 'done) - - not-u16 - (:cmpl ,(movitz:vector-type-tag :u32) :ecx) - (:jne 'not-u32) - (:movl (:eax (:ebx 4) 2) :ecx) ; u32 - (:call-global-constant box-u32-ecx) - (:jmp 'done) - - not-u32 - (:compile-form (:result-mode :ignore) - (error "Not a vector: ~S" vector)) - - done))) - (do-it))) + done))) + (do-it)))))) (t (vector &rest subscripts) (declare (ignore vector subscripts)) (error "Multi-dimensional arrays not implemented.")))) @@ -552,87 +585,34 @@ (cons (error "Multi-dimensional arrays not supported.")) (integer - (setf fill-pointer (if (integerp fill-pointer) fill-pointer dimensions)) - (cond - ((equal element-type 'character) - (let ((array (malloc-data-clumps (truncate (+ dimensions 7 8) 8)))) - (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags) - 0 :unsigned-byte16) - 0) - (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements) - 0 :unsigned-byte16) - dimensions) - (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type) - 0 :unsigned-byte16) - #.(movitz:vector-type-tag :character)) - (check-type array string) - (setf (fill-pointer array) fill-pointer) - (cond - (initial-element - (check-type initial-element character) - (dotimes (i dimensions) - (setf (char array i) initial-element))) - (initial-contents - (dotimes (i dimensions) - (setf (char array i) (elt initial-contents i))))) - array)) - ((member element-type '(u8 (unsigned-byte 8)) :test #'equal) - (let ((array (malloc-data-clumps (truncate (+ dimensions 7 8) 8)))) - (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags) - 0 :unsigned-byte16) - 0) - (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements) - 0 :unsigned-byte16) - dimensions) - (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type) - 0 :unsigned-byte16) - #.(movitz:vector-type-tag :u8)) - (setf (fill-pointer array) fill-pointer) - (cond - (initial-element - (dotimes (i dimensions) - (setf (aref array i) initial-element))) - (initial-contents - (replace array initial-contents))) - array)) - ((member element-type '(u32 (unsigned-byte 32)) :test #'equal) - (let ((array (malloc-data-words dimensions))) - (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags) - 0 :unsigned-byte16) - 0) - (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements) - 0 :unsigned-byte16) - dimensions) - (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type) - 0 :unsigned-byte16) - #.(movitz:vector-type-tag :u32)) - (setf (fill-pointer array) fill-pointer) - (cond - (initial-element - (dotimes (i dimensions) - (setf (aref array i) initial-element))) - (initial-contents - (replace array initial-contents))) - array)) - ((eq element-type :basic) - (check-type dimensions (and fixnum (integer 0 *))) - (let ((array (malloc-words dimensions))) - (setf (memref array #.(bt:slot-offset 'movitz::movitz-new-vector 'movitz::num-elements) - 0 :lisp) - dimensions) - (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type) - 0 :unsigned-byte16) - #.(movitz:basic-vector-type-tag :any-t)) - (when fill-pointer - (setf (fill-pointer array) fill-pointer)) - (cond - (initial-contents - (replace array initial-contents)) - (initial-element - (dotimes (i dimensions) - (setf (svref%unsafe array i) initial-element)))) - array)) - (t (let ((array (malloc-words dimensions))) + (let ((fill-pointer (if (integerp fill-pointer) + fill-pointer + dimensions))) + (cond + ((equal element-type 'character) + (let ((array (malloc-data-clumps (truncate (+ dimensions 7 8) 8)))) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags) + 0 :unsigned-byte16) + 0) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements) + 0 :unsigned-byte16) + dimensions) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type) + 0 :unsigned-byte16) + #.(movitz:vector-type-tag :character)) + (check-type array string) + (setf (fill-pointer array) fill-pointer) + (cond + (initial-element + (check-type initial-element character) + (dotimes (i dimensions) + (setf (char array i) initial-element))) + (initial-contents + (dotimes (i dimensions) + (setf (char array i) (elt initial-contents i))))) + array)) + ((member element-type '(u8 (unsigned-byte 8)) :test #'equal) + (let ((array (malloc-data-clumps (truncate (+ dimensions 7 8) 8)))) (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags) 0 :unsigned-byte16) 0) @@ -641,15 +621,70 @@ dimensions) (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type) 0 :unsigned-byte16) - #.(movitz:vector-type-tag :any-t)) + #.(movitz:vector-type-tag :u8)) + (setf (fill-pointer array) fill-pointer) + (cond + (initial-element + (dotimes (i dimensions) + (setf (aref array i) initial-element))) + (initial-contents + (replace array initial-contents))) + array)) + ((member element-type '(u32 (unsigned-byte 32)) :test #'equal) + (let ((array (malloc-data-words dimensions))) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags) + 0 :unsigned-byte16) + 0) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements) + 0 :unsigned-byte16) + dimensions) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type) + 0 :unsigned-byte16) + #.(movitz:vector-type-tag :u32)) + (setf (fill-pointer array) fill-pointer) + (cond + (initial-element + (dotimes (i dimensions) + (setf (aref array i) initial-element))) + (initial-contents + (replace array initial-contents))) + array)) + ((eq element-type :basic) + (check-type dimensions (and fixnum (integer 0 *))) + (let ((array (malloc-words dimensions))) + (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements) + 0 :lisp) + dimensions) + (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type) + 0 :unsigned-byte16) + #.(movitz:basic-vector-type-tag :any-t)) (setf (fill-pointer array) fill-pointer) + (warn "fp: ~S/~S" fill-pointer (fill-pointer array)) (cond (initial-contents (replace array initial-contents)) (initial-element (dotimes (i dimensions) (setf (svref%unsafe array i) initial-element)))) - array)))))) + array)) + (t (let ((array (malloc-words dimensions))) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags) + 0 :unsigned-byte16) + 0) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements) + 0 :unsigned-byte16) + dimensions) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type) + 0 :unsigned-byte16) + #.(movitz:vector-type-tag :any-t)) + (setf (fill-pointer array) fill-pointer) + (cond + (initial-contents + (replace array initial-contents)) + (initial-element + (dotimes (i dimensions) + (setf (svref%unsafe array i) initial-element)))) + array))))))) (defun vector (&rest objects) "=> vector" From ffjeld at common-lisp.net Thu Jun 17 19:44:44 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 17 Jun 2004 12:44:44 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13564 Modified Files: sequences.lisp Log Message: The new vector structure is called basic-vectors. This check-in adds some support for this structure. The plan is to add more-or-less complete support for the new structure, and then migrate everything to this, and then eventually remove the old structure "movitz-vector". Date: Thu Jun 17 12:44:44 2004 Author: ffjeld Index: movitz/losp/muerte/sequences.lisp diff -u movitz/losp/muerte/sequences.lisp:1.11 movitz/losp/muerte/sequences.lisp:1.12 --- movitz/losp/muerte/sequences.lisp:1.11 Thu Jun 10 09:28:55 2004 +++ movitz/losp/muerte/sequences.lisp Thu Jun 17 12:44:44 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.11 2004/06/10 16:28:55 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.12 2004/06/17 19:44:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -54,8 +54,21 @@ (t (sequence-double-dispatch-error ,seq0 ,seq1)))) (defun length (sequence) - (sequence-dispatch sequence - (vector + (etypecase sequence + (basic-vector + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :ebx) sequence) + (:movl (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)) + :eax) + (:testl ,(logxor #xffffffff (1- (expt 2 14))) :eax) + (:jnz 'basic-vector-length-ok) + (:movzxw (:ebx #.(bt:slot-offset 'movitz::movitz-basic-vector 'movitz::fill-pointer)) + :eax) + basic-vector-length-ok))) + (do-it))) + (old-vector (vector-fill-pointer sequence)) (list (do ((x sequence (cdr x)) From ffjeld at common-lisp.net Thu Jun 17 19:44:49 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 17 Jun 2004 12:44:49 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13739 Modified Files: typep.lisp Log Message: The new vector structure is called basic-vectors. This check-in adds some support for this structure. The plan is to add more-or-less complete support for the new structure, and then migrate everything to this, and then eventually remove the old structure "movitz-vector". Date: Thu Jun 17 12:44:49 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.18 movitz/losp/muerte/typep.lisp:1.19 --- movitz/losp/muerte/typep.lisp:1.18 Thu Jun 17 02:49:28 2004 +++ movitz/losp/muerte/typep.lisp Thu Jun 17 12:44:49 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.18 2004/06/17 09:49:28 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.19 2004/06/17 19:44:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -235,8 +235,10 @@ (make-other-typep :funobj)) ((basic-vector) (make-other-typep :basic-vector)) - ((vector array) + ((old-vector) (make-other-typep :vector)) + ((vector array) + `(typep ,object '(or old-vector basic-vector))) (simple-vector (make-vector-typep :any-t)) (string @@ -280,7 +282,7 @@ (= (1+ movitz:+movitz-most-positive-fixnum+) lower-limit)) `(with-inline-assembly-case () (do-case (t :boolean-zf=1 :labels (plusp-ok)) - (:compile-form (:result-mode :eax) ,object) + (:compile-form (:result-mode :eax) ,object) (:leal (:eax ,(- (movitz:tag :other))) :ecx) (:testb 7 :cl) (:jnz 'plusp-ok) From ffjeld at common-lisp.net Mon Jun 21 07:32:56 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 21 Jun 2004 00:32:56 -0700 Subject: [movitz-cvs] CVS update: ia-x86/instr-add.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv16984 Modified Files: instr-add.lisp Log Message: Minor edits. Date: Mon Jun 21 00:32:56 2004 Author: ffjeld Index: ia-x86/instr-add.lisp diff -u ia-x86/instr-add.lisp:1.2 ia-x86/instr-add.lisp:1.3 --- ia-x86/instr-add.lisp:1.2 Fri Jan 16 03:54:14 2004 +++ ia-x86/instr-add.lisp Mon Jun 21 00:32:56 2004 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 20012000, 2003, +;;;; Copyright (C) 2001-2004, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: instr-add.lisp @@ -9,11 +9,11 @@ ;;;; Created at: Sat Jan 29 20:20:18 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: instr-add.lisp,v 1.2 2004/01/16 11:54:14 ffjeld Exp $ +;;;; $Id: instr-add.lisp,v 1.3 2004/06/21 07:32:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ -(in-package "IA-X86-INSTR") +(in-package #:ia-x86-instr) ;;; ---------------------------------------------------------------- ;;; ADD [IISR page 11-22] From ffjeld at common-lisp.net Mon Jun 21 07:33:00 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 21 Jun 2004 00:33:00 -0700 Subject: [movitz-cvs] CVS update: ia-x86/instr-and-or.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv17092 Modified Files: instr-and-or.lisp Log Message: Minor edits. Date: Mon Jun 21 00:33:00 2004 Author: ffjeld Index: ia-x86/instr-and-or.lisp diff -u ia-x86/instr-and-or.lisp:1.2 ia-x86/instr-and-or.lisp:1.3 --- ia-x86/instr-and-or.lisp:1.2 Fri Jan 16 03:54:14 2004 +++ ia-x86/instr-and-or.lisp Mon Jun 21 00:33:00 2004 @@ -1,19 +1,19 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 20012000, +;;;; Copyright (C) 2001-2004, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; -;;;; Filename: ia-x86-instr-and-or.lisp +;;;; Filename: instr-and-or.lisp ;;;; Description: Bitwise boolean operations. ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Feb 1 17:39:09 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: instr-and-or.lisp,v 1.2 2004/01/16 11:54:14 ffjeld Exp $ +;;;; $Id: instr-and-or.lisp,v 1.3 2004/06/21 07:33:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ -(in-package "IA-X86-INSTR") +(in-package #:ia-x86-instr) ;;; ---------------------------------------------------------------- ;;; AND [IISR page 11-64] From ffjeld at common-lisp.net Mon Jun 21 07:33:50 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 21 Jun 2004 00:33:50 -0700 Subject: [movitz-cvs] CVS update: ia-x86/read.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv18034 Modified Files: read.lisp Log Message: Minor adjustments to the assembly read syntax. Date: Mon Jun 21 00:33:50 2004 Author: ffjeld Index: ia-x86/read.lisp diff -u ia-x86/read.lisp:1.4 ia-x86/read.lisp:1.5 --- ia-x86/read.lisp:1.4 Mon Feb 9 16:13:29 2004 +++ ia-x86/read.lisp Mon Jun 21 00:33:50 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Jul 31 13:54:27 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: read.lisp,v 1.4 2004/02/10 00:13:29 ffjeld Exp $ +;;;; $Id: read.lisp,v 1.5 2004/06/21 07:33:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -179,7 +179,7 @@ 'label label)))) (:funcall (make-instance 'calculated-operand - :calculation (car datum) + :calculation (coerce (car datum) 'function) :sub-operands (mapcar #'read-operand (cdr datum))))))) (integer (make-instance 'operand-number @@ -235,7 +235,8 @@ (:align (make-instance 'alignment :type operand-list)) ((nil) - (mapcar #'read-operand operand-list)) + (mapcar #'read-operand operand-list) + nil) (t (make-instance (or (gethash instr-name *find-instruction-cache*) (setf (gethash instr-name *find-instruction-cache*) (multiple-value-bind (instr-symbol instr-symbol-status) From ffjeld at common-lisp.net Mon Jun 21 07:48:59 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 21 Jun 2004 00:48:59 -0700 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv10722 Modified Files: compiler.lisp Log Message: sbcl idiocy. Date: Mon Jun 21 00:48:59 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.68 movitz/compiler.lisp:1.69 --- movitz/compiler.lisp:1.68 Thu Jun 10 12:30:19 2004 +++ movitz/compiler.lisp Mon Jun 21 00:48:59 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.68 2004/06/10 19:30:19 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.69 2004/06/21 07:48:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2658,7 +2658,7 @@ (member binding (find-read-bindings i) :test #'eq))) (cdr init-pc) - :end 15)) + #-sbcl :end #-sbcl 15)) (binding-destination (third load-instruction)) (distance (position load-instruction (cdr init-pc)))) (multiple-value-bind (free-registers more-later-p) From ffjeld at common-lisp.net Tue Jun 22 21:41:58 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 22 Jun 2004 14:41:58 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2150 Modified Files: scavenge.lisp Log Message: Fixed nasty, stupid mistake in map-heap-words. Date: Tue Jun 22 14:41:58 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.11 movitz/losp/muerte/scavenge.lisp:1.12 --- movitz/losp/muerte/scavenge.lisp:1.11 Wed Jun 16 00:42:55 2004 +++ movitz/losp/muerte/scavenge.lisp Tue Jun 22 14:41:57 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.11 2004/06/16 07:42:55 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.12 2004/06/22 21:41:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -92,17 +92,18 @@ #.(bt:enum-value 'movitz:movitz-vector-element-type :character))) (assert (evenp scan) () "Scanned #x~Z at odd address #x~X." x scan) - (let ((len (memref scan (word-upper16 x) 0 :unsigned-byte16))) + (let ((len (word-upper16 x))) + #+ignore (warn "scavenge at #x~X u8 vector len ~D." scan len) (incf scan (1+ (* 2 (truncate (+ 7 len) 8)))))) ((scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16)) (assert (evenp scan) () "Scanned #x~Z at odd address #x~X." x scan) - (let ((len (memref scan (word-upper16 x) 0 :unsigned-byte16))) + (let ((len (word-upper16 x))) (incf scan (1+ (* 2 (truncate (+ 3 len) 4)))))) ((scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32)) (assert (evenp scan) () "Scanned #x~Z at odd address #x~X." x scan) - (let ((len (memref scan (word-upper16 x) 0 :unsigned-byte16))) + (let ((len (word-upper16 x))) (incf scan (1+ (logand (1+ len) -2))))) ((eq x (fixnum-word 3)) (incf scan) From ffjeld at common-lisp.net Tue Jun 22 22:38:48 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 22 Jun 2004 15:38:48 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2400 Modified Files: arrays.lisp Log Message: More improvements of the new basic-vectors. Date: Tue Jun 22 15:38:48 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.25 movitz/losp/muerte/arrays.lisp:1.26 --- movitz/losp/muerte/arrays.lisp:1.25 Thu Jun 17 12:44:39 2004 +++ movitz/losp/muerte/arrays.lisp Tue Jun 22 15:38:48 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.25 2004/06/17 19:44:39 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.26 2004/06/22 22:38:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -229,7 +229,7 @@ ((do-it () `(with-inline-assembly (:returns :eax) (:declare-label-set basic-vector-dispatcher - (any-t unknown unknown unknown + (any-t character u8 unknown unknown unknown unknown unknown)) (:compile-two-forms (:eax :ebx) array index) (:movl (:eax ,movitz:+other-type-offset+) :ecx) @@ -243,10 +243,6 @@ (error "Illegal index: ~S." index)))) (:shrl 8 :ecx) (:andl 7 :ecx) - (:jmp (:esi (:ecx 4) 'basic-vector-dispatcher - ,(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0))) - (() () '(:sub-program (unknown) (:int 100))) - any-t (:cmpl :ebx (:eax ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))) (:jbe '(:sub-program (out-of-bounds) @@ -256,8 +252,28 @@ (memref array ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements) 0 :lisp))))) + (:jmp (:esi (:ecx 4) 'basic-vector-dispatcher + ,(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0))) + + (() () '(:sub-program (unknown) (:int 100))) + u8 + (:movl :ebx :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:movzxb (:eax :ecx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)) + :ecx) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax) + (:jmp 'return) + character + (:movl :ebx :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:movl ,(movitz:tag :character) :eax) + (:movb (:eax :ecx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)) + :ah) + (:jmp 'return) + any-t (:movl (:eax :ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)) - :eax)))) + :eax) + return))) (do-it))) (old-vector (let ((vector array)) @@ -332,89 +348,117 @@ (defun (setf aref) (value vector &rest subscripts) (numargs-case (3 (value vector index) - (macrolet - ((do-it () - `(with-inline-assembly (:returns :ebx) - (:compile-form (:result-mode :ebx) value) - (:compile-form (:result-mode :eax) vector) - - (:leal (:eax ,(- (movitz:tag :other))) :ecx) - (:testb 7 :cl) - (:jnz '(:sub-program () - (:compile-form (:result-mode :ignore) - (error "Not a vector: ~S" vector)))) - (:movzxw (:eax ,movitz:+other-type-offset+) :edx) - - (:compile-form (:result-mode :ecx) index) - (:testb ,movitz::+movitz-fixnum-zmask+ :cl) - (:jnz '(:sub-program () (:int 107))) ; index not fixnum - (:andl ,(ash #xffff movitz::+movitz-fixnum-shift+) :ecx) - (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) - - (:cmpw (:eax ,(bt:slot-offset 'movitz:movitz-vector 'movitz::num-elements)) :cx) - (:jae '(:sub-program () (:int 61) (:jmp (:pc+ -4)))) ; index out of bounds - - (:cmpl ,(movitz:vector-type-tag :any-t) :edx) - (:jnz 'not-any-t) - - (:movl :ebx (:eax (:ecx 4) 2)) - (:jmp 'done) - - not-any-t - (:cmpl ,(movitz:vector-type-tag :character) :edx) - (:jnz 'not-character) - (:cmpb ,(movitz:tag :character) :bl) - (:jnz '(:sub-program (not-character-value) - (:compile-form (:result-mode :ignore) - (error "Value not character: ~S" value)))) - (:movb :bh (:eax :ecx 2)) - (:jmp 'done) - - not-character - (:cmpl ,(movitz:vector-type-tag :u8) :edx) - (:jnz 'not-u8) - (:testl ,(cl:ldb (cl:byte 32 0) - (- -1 (* #xff movitz:+movitz-fixnum-factor+))) - :ebx) - (:jnz '(:sub-program (not-u8-value) - (:compile-form (:result-mode :ignore) - (error "Value not (unsigned-byte 8): ~S" value)))) - (:shrl ,movitz:+movitz-fixnum-shift+ :ebx) - (:movb :bl (:eax (:ecx 1) ,(bt:slot-offset 'movitz:movitz-vector 'movitz::data))) - (:leal ((:ebx ,movitz:+movitz-fixnum-factor+)) :ebx) - (:jmp 'done) - - - not-u8 - (:cmpl ,(movitz:vector-type-tag :u16) :edx) - (:jnz 'not-u16) - (:testl ,(ldb (byte 32 0) - (- -1 (* #xffff movitz:+movitz-fixnum-factor+))) - :ebx) - (:jnz '(:sub-program (not-u16-value) - (:compile-form (:result-mode :ignore) - (error "Value not (unsigned-byte 16): ~S" value)))) - (:shrl ,movitz:+movitz-fixnum-shift+ :ebx) - (:movw :bx (:eax (:ecx 2) ,(bt:slot-offset 'movitz:movitz-vector 'movitz::data))) - (:leal ((:ebx ,movitz:+movitz-fixnum-factor+)) :ebx) - (:jmp 'done) - - not-u16 - (:cmpl ,(movitz:vector-type-tag :u32) :edx) - (:jnz 'not-u32) - ;; EBX=value, EAX=vector, ECX=index - (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :edx) - (:xchgl :eax :ebx) - ;; EAX=value, EBX=vector, EDX=index - (:call-global-constant unbox-u32) - (:movl :ecx (:ebx (:edx 1) ,(bt:slot-offset 'movitz:movitz-vector 'movitz::data))) - (:movl :eax :ebx) - (:jmp 'done) - - not-u32 - (:compile-form (:result-mode :ignore) (error "Not a vector: ~S" vector)) - done))) - (do-it))) + (etypecase vector + (basic-vector + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) value vector) + (:leal (:ebx ,(- (movitz:tag :other))) :ecx) + (:compile-form (:result-mode :edx) index) + (:testb 7 :cl) + (:jnz '(:sub-program (not-a-vector) + (:compile-form (:result-mode :ignore) + (error "Not a vector: ~S" vector)))) + (:movl (:ebx ,movitz:+other-type-offset+) :ecx) + (:andl #xffff :ecx) + (:testb ,movitz:+movitz-fixnum-zmask+ :dl) + (:jnz 'not-a-vector) + (:cmpl ,(movitz:basic-vector-type-tag :any-t) :ecx) + (:jne 'not-any-t-vector) + (:movl :eax + (:ebx :edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) + (:jmp 'return) + not-any-t-vector + (:compile-form (:result-mode :ignore) + (error "Not a vector: ~S" vector)) + return) + )) + (do-it))) + (old-vector + (macrolet + ((do-it () + `(with-inline-assembly (:returns :ebx) + (:compile-form (:result-mode :ebx) value) + (:compile-form (:result-mode :eax) vector) + + (:leal (:eax ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jnz '(:sub-program () + (:compile-form (:result-mode :ignore) + (error "Not a vector: ~S" vector)))) + (:movzxw (:eax ,movitz:+other-type-offset+) :edx) + + (:compile-form (:result-mode :ecx) index) + (:testb ,movitz::+movitz-fixnum-zmask+ :cl) + (:jnz '(:sub-program () (:int 107))) ; index not fixnum + (:andl ,(ash #xffff movitz::+movitz-fixnum-shift+) :ecx) + (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) + + (:cmpw (:eax ,(bt:slot-offset 'movitz:movitz-vector 'movitz::num-elements)) :cx) + (:jae '(:sub-program () (:int 61) (:jmp (:pc+ -4)))) ; index out of bounds + + (:cmpl ,(movitz:vector-type-tag :any-t) :edx) + (:jnz 'not-any-t) + + (:movl :ebx (:eax (:ecx 4) 2)) + (:jmp 'done) + + not-any-t + (:cmpl ,(movitz:vector-type-tag :character) :edx) + (:jnz 'not-character) + (:cmpb ,(movitz:tag :character) :bl) + (:jnz '(:sub-program (not-character-value) + (:compile-form (:result-mode :ignore) + (error "Value not character: ~S" value)))) + (:movb :bh (:eax :ecx 2)) + (:jmp 'done) + + not-character + (:cmpl ,(movitz:vector-type-tag :u8) :edx) + (:jnz 'not-u8) + (:testl ,(cl:ldb (cl:byte 32 0) + (- -1 (* #xff movitz:+movitz-fixnum-factor+))) + :ebx) + (:jnz '(:sub-program (not-u8-value) + (:compile-form (:result-mode :ignore) + (error "Value not (unsigned-byte 8): ~S" value)))) + (:shrl ,movitz:+movitz-fixnum-shift+ :ebx) + (:movb :bl (:eax (:ecx 1) ,(bt:slot-offset 'movitz:movitz-vector 'movitz::data))) + (:leal ((:ebx ,movitz:+movitz-fixnum-factor+)) :ebx) + (:jmp 'done) + + + not-u8 + (:cmpl ,(movitz:vector-type-tag :u16) :edx) + (:jnz 'not-u16) + (:testl ,(ldb (byte 32 0) + (- -1 (* #xffff movitz:+movitz-fixnum-factor+))) + :ebx) + (:jnz '(:sub-program (not-u16-value) + (:compile-form (:result-mode :ignore) + (error "Value not (unsigned-byte 16): ~S" value)))) + (:shrl ,movitz:+movitz-fixnum-shift+ :ebx) + (:movw :bx (:eax (:ecx 2) ,(bt:slot-offset 'movitz:movitz-vector 'movitz::data))) + (:leal ((:ebx ,movitz:+movitz-fixnum-factor+)) :ebx) + (:jmp 'done) + + not-u16 + (:cmpl ,(movitz:vector-type-tag :u32) :edx) + (:jnz 'not-u32) + ;; EBX=value, EAX=vector, ECX=index + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :edx) + (:xchgl :eax :ebx) + ;; EAX=value, EBX=vector, EDX=index + (:call-global-constant unbox-u32) + (:movl :ecx (:ebx (:edx 1) ,(bt:slot-offset 'movitz:movitz-vector 'movitz::data))) + (:movl :eax :ebx) + (:jmp 'done) + + not-u32 + (:compile-form (:result-mode :ignore) (error "Not a vector: ~S" vector)) + done))) + (do-it))))) (t (value vector &rest subscripts) (declare (ignore value vector subscripts)) (error "Multi-dimensional arrays not implemented.")))) @@ -437,41 +481,88 @@ (setf (svref%unsafe simple-vector index) value)) (defun svref (simple-vector index) - (macrolet ((do-svref () - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ebx) simple-vector index) - (:leal (:eax ,(- (movitz::tag :other))) :ecx) - (:testb 7 :cl) - (:jnz '(:sub-program (not-simple-vector) - (:int 66))) - (:cmpw ,(dpb (bt:enum-value 'movitz::movitz-vector-element-type :any-t) - (byte 8 8) - (movitz:tag :vector)) - (:eax ,(bt:slot-offset 'movitz::movitz-vector 'movitz::type))) - (:jne 'not-simple-vector) - (:testb #.movitz::+movitz-fixnum-zmask+ :bl) - (:jnz '(:sub-program (not-fixnum) - (:int 107))) - (:movzxw (:eax #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)) - :ecx) - (:shll #.movitz::+movitz-fixnum-shift+ :ecx) - (:xchgl :ecx :ebx) - (:cmpl :ecx :ebx) - (:jna '(:sub-program (index-out-of-bounds) - (:int 70))) - ,@(if (= 4 movitz::+movitz-fixnum-factor+) - `((:movl (:eax :ecx #.(bt:slot-offset 'movitz::movitz-vector 'movitz::data)) - :eax)) - `((:shrl #.movitz::+movitz-fixnum-shift+ :ecx) - (:movl (:eax (:ecx 4) #.(bt:slot-offset 'movitz::movitz-vector 'movitz::data)) - :eax)))))) - (do-svref))) + (etypecase simple-vector + (basic-vector + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) simple-vector index) + (:leal (:eax ,(- (movitz::tag :other))) :ecx) + (:testb 7 :cl) + (:jne '(:sub-program (not-basic-simple-vector) + (:compile-form (:result-mode :ignore) + (error "Not a simple-vector: ~S." simple-vector)))) + (:movl (:eax ,movitz:+other-type-offset+) :ecx) + (:testb ,movitz:+movitz-fixnum-zmask+ :bl) + (:jnz '(:sub-program (illegal-index) + (:compile-form (:result-mode :ignore) + (error "Illegal index: ~S." index)))) + (:cmpw ,(movitz:basic-vector-type-tag :any-t) :cx) + (:jne 'not-basic-simple-vector) + (:movl (:eax :ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)) + :eax) + ))) + (do-it))) + (old-vector + (macrolet + ((do-svref () + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) simple-vector index) + (:leal (:eax ,(- (movitz::tag :other))) :ecx) + (:testb 7 :cl) + (:jnz '(:sub-program (not-simple-vector) + (:int 66))) + (:cmpw ,(dpb (bt:enum-value 'movitz::movitz-vector-element-type :any-t) + (byte 8 8) + (movitz:tag :vector)) + (:eax ,(bt:slot-offset 'movitz::movitz-vector 'movitz::type))) + (:jne 'not-simple-vector) + (:testb #.movitz::+movitz-fixnum-zmask+ :bl) + (:jnz '(:sub-program (not-fixnum) + (:int 107))) + (:movzxw (:eax #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)) + :ecx) + (:shll #.movitz::+movitz-fixnum-shift+ :ecx) + (:xchgl :ecx :ebx) + (:cmpl :ecx :ebx) + (:jna '(:sub-program (index-out-of-bounds) + (:int 70))) + ,@(if (= 4 movitz::+movitz-fixnum-factor+) + `((:movl (:eax :ecx #.(bt:slot-offset 'movitz::movitz-vector 'movitz::data)) + :eax)) + `((:shrl #.movitz::+movitz-fixnum-shift+ :ecx) + (:movl (:eax (:ecx 4) #.(bt:slot-offset 'movitz::movitz-vector 'movitz::data)) + :eax)))))) + (do-svref))))) (defun (setf svref) (value simple-vector index) - (check-type simple-vector simple-vector) - (assert (below index (vector-dimension simple-vector))) - (setf (memref simple-vector 2 index :lisp) value)) + (etypecase simple-vector + (basic-vector + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:ebx :edx) simple-vector index) + (:leal (:ebx ,(- (movitz::tag :other))) :ecx) + (:testb 7 :cl) + (:jne '(:sub-program (not-basic-simple-vector) + (:compile-form (:result-mode :ignore) + (error "Not a simple-vector: ~S." simple-vector)))) + (:movl (:ebx ,movitz:+other-type-offset+) :ecx) + (:testb ,movitz:+movitz-fixnum-zmask+ :dl) + (:jnz '(:sub-program (illegal-index) + (:compile-form (:result-mode :ignore) + (error "Illegal index: ~S." index)))) + (:compile-form (:result-mode :eax) value) + (:cmpw ,(movitz:basic-vector-type-tag :any-t) :cx) + (:jne 'not-basic-simple-vector) + (:movl :eax + (:ebx :edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))))) + (do-it))) + (old-vector + (check-type simple-vector simple-vector) + (assert (below index (vector-dimension simple-vector))) + (setf (memref simple-vector 2 index :lisp) value)))) ;;; string accessors @@ -585,53 +676,92 @@ (cons (error "Multi-dimensional arrays not supported.")) (integer - (let ((fill-pointer (if (integerp fill-pointer) - fill-pointer - dimensions))) - (cond - ((equal element-type 'character) - (let ((array (malloc-data-clumps (truncate (+ dimensions 7 8) 8)))) - (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags) - 0 :unsigned-byte16) - 0) - (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements) - 0 :unsigned-byte16) + (cond + ((equal element-type 'character) + (let ((array (malloc-data-clumps (truncate (+ dimensions 7 8) 8)))) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags) + 0 :unsigned-byte16) + 0) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements) + 0 :unsigned-byte16) + dimensions) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type) + 0 :unsigned-byte16) + #.(movitz:vector-type-tag :character)) + (check-type array string) + (when fill-pointer + (setf (fill-pointer array) fill-pointer)) + (cond + (initial-element + (check-type initial-element character) + (dotimes (i dimensions) + (setf (char array i) initial-element))) + (initial-contents + (dotimes (i dimensions) + (setf (char array i) (elt initial-contents i))))) + array)) + ((member element-type '(u8 (unsigned-byte 8)) :test #'equal) + (let ((array (malloc-data-clumps (truncate (+ dimensions 7 8) 8)))) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags) + 0 :unsigned-byte16) + 0) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements) + 0 :unsigned-byte16) + dimensions) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type) + 0 :unsigned-byte16) + #.(movitz:vector-type-tag :u8)) + (setf (fill-pointer array) + (or fill-pointer dimensions)) + (cond + (initial-element + (dotimes (i dimensions) + (setf (aref array i) initial-element))) + (initial-contents + (replace array initial-contents))) + array)) + ((member element-type '(u32 (unsigned-byte 32)) :test #'equal) + (let ((array (malloc-data-words dimensions))) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags) + 0 :unsigned-byte16) + 0) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements) + 0 :unsigned-byte16) + dimensions) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type) + 0 :unsigned-byte16) + #.(movitz:vector-type-tag :u32)) + (when fill-pointer + (setf (fill-pointer array) fill-pointer)) + (cond + (initial-element + (dotimes (i dimensions) + (setf (aref array i) initial-element))) + (initial-contents + (replace array initial-contents))) + array)) + (t #+ignore (eq element-type :basic) + (check-type dimensions (and fixnum (integer 0 *))) + (let ((array (malloc-words dimensions))) + (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements) + 0 :lisp) dimensions) - (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type) + (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type) 0 :unsigned-byte16) - #.(movitz:vector-type-tag :character)) - (check-type array string) - (setf (fill-pointer array) fill-pointer) + #.(movitz:basic-vector-type-tag :any-t)) + (setf (fill-pointer array) + (case fill-pointer + ((nil t) dimensions) + (t fill-pointer))) (cond - (initial-element - (check-type initial-element character) - (dotimes (i dimensions) - (setf (char array i) initial-element))) (initial-contents - (dotimes (i dimensions) - (setf (char array i) (elt initial-contents i))))) - array)) - ((member element-type '(u8 (unsigned-byte 8)) :test #'equal) - (let ((array (malloc-data-clumps (truncate (+ dimensions 7 8) 8)))) - (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags) - 0 :unsigned-byte16) - 0) - (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements) - 0 :unsigned-byte16) - dimensions) - (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type) - 0 :unsigned-byte16) - #.(movitz:vector-type-tag :u8)) - (setf (fill-pointer array) fill-pointer) - (cond + (replace array initial-contents)) (initial-element (dotimes (i dimensions) - (setf (aref array i) initial-element))) - (initial-contents - (replace array initial-contents))) + (setf (svref%unsafe array i) initial-element)))) array)) - ((member element-type '(u32 (unsigned-byte 32)) :test #'equal) - (let ((array (malloc-data-words dimensions))) + #+ignore + (t (let ((array (malloc-words dimensions))) (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags) 0 :unsigned-byte16) 0) @@ -640,51 +770,16 @@ dimensions) (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type) 0 :unsigned-byte16) - #.(movitz:vector-type-tag :u32)) - (setf (fill-pointer array) fill-pointer) - (cond - (initial-element - (dotimes (i dimensions) - (setf (aref array i) initial-element))) - (initial-contents - (replace array initial-contents))) - array)) - ((eq element-type :basic) - (check-type dimensions (and fixnum (integer 0 *))) - (let ((array (malloc-words dimensions))) - (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements) - 0 :lisp) - dimensions) - (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type) - 0 :unsigned-byte16) - #.(movitz:basic-vector-type-tag :any-t)) - (setf (fill-pointer array) fill-pointer) - (warn "fp: ~S/~S" fill-pointer (fill-pointer array)) + #.(movitz:vector-type-tag :any-t)) + (setf (fill-pointer array) + (or fill-pointer dimensions)) (cond (initial-contents (replace array initial-contents)) (initial-element (dotimes (i dimensions) (setf (svref%unsafe array i) initial-element)))) - array)) - (t (let ((array (malloc-words dimensions))) - (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags) - 0 :unsigned-byte16) - 0) - (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements) - 0 :unsigned-byte16) - dimensions) - (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type) - 0 :unsigned-byte16) - #.(movitz:vector-type-tag :any-t)) - (setf (fill-pointer array) fill-pointer) - (cond - (initial-contents - (replace array initial-contents)) - (initial-element - (dotimes (i dimensions) - (setf (svref%unsafe array i) initial-element)))) - array))))))) + array)))))) (defun vector (&rest objects) "=> vector" From ffjeld at common-lisp.net Wed Jun 23 10:15:10 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 23 Jun 2004 03:15:10 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1725 Modified Files: arrays.lisp Log Message: Some fixes of transitional code. Still working on the new basic-vectors. Date: Wed Jun 23 03:15:10 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.26 movitz/losp/muerte/arrays.lisp:1.27 --- movitz/losp/muerte/arrays.lisp:1.26 Tue Jun 22 15:38:48 2004 +++ movitz/losp/muerte/arrays.lisp Wed Jun 23 03:15:10 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.26 2004/06/22 22:38:48 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.27 2004/06/23 10:15:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -689,8 +689,8 @@ 0 :unsigned-byte16) #.(movitz:vector-type-tag :character)) (check-type array string) - (when fill-pointer - (setf (fill-pointer array) fill-pointer)) + (setf (fill-pointer array) + (or fill-pointer dimensions)) (cond (initial-element (check-type initial-element character) @@ -731,8 +731,8 @@ (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type) 0 :unsigned-byte16) #.(movitz:vector-type-tag :u32)) - (when fill-pointer - (setf (fill-pointer array) fill-pointer)) + (setf (fill-pointer array) + (or fill-pointer dimensions)) (cond (initial-element (dotimes (i dimensions) From ffjeld at common-lisp.net Tue Jun 29 23:15:47 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 29 Jun 2004 16:15:47 -0700 Subject: [movitz-cvs] CVS update: movitz/procfs-image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv23596 Modified Files: procfs-image.lisp Log Message: Minor bits about basic-vectors. Date: Tue Jun 29 16:15:47 2004 Author: ffjeld Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.7 movitz/procfs-image.lisp:1.8 --- movitz/procfs-image.lisp:1.7 Sat Jun 5 20:02:45 2004 +++ movitz/procfs-image.lisp Tue Jun 29 16:15:47 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.7 2004/06/06 03:02:45 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.8 2004/06/29 23:15:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -110,6 +110,7 @@ ((not movitz-object) expr) ((or movitz-nil movitz-constant-block) nil) + (movitz-std-instance expr) (movitz-symbol (intern (movitz-print (movitz-symbol-name expr)))) (movitz-string @@ -117,7 +118,7 @@ (movitz-vector-symbolic-data expr))) (movitz-fixnum (movitz-fixnum-value expr)) - (movitz-vector + ((or movitz-vector movitz-basic-vector) (map 'vector #'movitz-print (movitz-vector-symbolic-data expr))) (movitz-cons (cons (movitz-print (movitz-car expr)) From ffjeld at common-lisp.net Tue Jun 29 23:15:52 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 29 Jun 2004 16:15:52 -0700 Subject: [movitz-cvs] CVS update: movitz/stream-image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24434 Modified Files: stream-image.lisp Log Message: Minor bits about basic-vectors. Date: Tue Jun 29 16:15:52 2004 Author: ffjeld Index: movitz/stream-image.lisp diff -u movitz/stream-image.lisp:1.6 movitz/stream-image.lisp:1.7 --- movitz/stream-image.lisp:1.6 Tue Jun 1 08:16:59 2004 +++ movitz/stream-image.lisp Tue Jun 29 16:15:52 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Aug 27 14:46:50 2001 ;;;; -;;;; $Id: stream-image.lisp,v 1.6 2004/06/01 15:16:59 ffjeld Exp $ +;;;; $Id: stream-image.lisp,v 1.7 2004/06/29 23:15:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -87,6 +87,8 @@ (case type-tag (:funobj (read-binary 'movitz-funobj (image-stream image))) + (:basic-vector + (read-binary 'movitz-basic-vector (image-stream image))) (:vector (read-binary 'movitz-vector (image-stream image))) (:defstruct From ffjeld at common-lisp.net Tue Jun 29 23:16:43 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 29 Jun 2004 16:16:43 -0700 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv30270 Modified Files: image.lisp Log Message: Fixed movitz-word-and-print which hasn't been working for a while. Date: Tue Jun 29 16:16:43 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.39 movitz/image.lisp:1.40 --- movitz/image.lisp:1.39 Thu Jun 10 12:31:06 2004 +++ movitz/image.lisp Tue Jun 29 16:16:43 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.39 2004/06/10 19:31:06 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.40 2004/06/29 23:16:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -730,8 +730,8 @@ (assert (eq type 'word)) (movitz-word-by-image *image* word)) -(defun movitz-word-and-print (word) - (movitz-print (movitz-word word))) +(defun movitz-word-and-print (word &optional (type 'word)) + (movitz-print (movitz-word word type))) (defmethod movitz-word-by-image ((image symbolic-image) word) (case (extract-tag word) From ffjeld at common-lisp.net Tue Jun 29 23:17:23 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 29 Jun 2004 16:17:23 -0700 Subject: [movitz-cvs] CVS update: movitz/compiler-types.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv31575 Modified Files: compiler-types.lisp Log Message: Teach basic-typep about basic-vectors. Date: Tue Jun 29 16:17:23 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.14 movitz/compiler-types.lisp:1.15 --- movitz/compiler-types.lisp:1.14 Wed Jun 9 10:18:36 2004 +++ movitz/compiler-types.lisp Tue Jun 29 16:17:22 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.14 2004/06/09 17:18:36 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.15 2004/06/29 23:17:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -223,7 +223,7 @@ (symbol (typep x 'movitz-symbol)) ((vector array) - (typep x 'movitz-vector)) + (typep x '(or movitz-basic-vector movitz-vector))) (fixnum (typep x 'movitz-fixnum)) (bignum From ffjeld at common-lisp.net Tue Jun 29 23:19:21 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 29 Jun 2004 16:19:21 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/hash-tables.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7585 Modified Files: hash-tables.lisp Log Message: Don't use the bogus operator vector-dimension. Date: Tue Jun 29 16:19:21 2004 Author: ffjeld Index: movitz/losp/muerte/hash-tables.lisp diff -u movitz/losp/muerte/hash-tables.lisp:1.2 movitz/losp/muerte/hash-tables.lisp:1.3 --- movitz/losp/muerte/hash-tables.lisp:1.2 Mon Jan 19 03:23:46 2004 +++ movitz/losp/muerte/hash-tables.lisp Tue Jun 29 16:19:21 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Feb 19 19:09:05 2001 ;;;; -;;;; $Id: hash-tables.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $ +;;;; $Id: hash-tables.lisp,v 1.3 2004/06/29 23:19:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -58,7 +58,7 @@ (defun hash-table-iterator (bucket index) (when index - (do ((length (vector-dimension bucket))) + (do ((length (array-dimension bucket 0))) ((>= index length) nil) (unless (eq (svref bucket index) '#.movitz::+undefined-hash-key+) @@ -127,7 +127,7 @@ (defun gethash (key hash-table &optional default) (let* ((test (hash-table-test hash-table)) (bucket (hash-table-bucket hash-table)) - (bucket-length (vector-dimension bucket)) + (bucket-length (length bucket)) (start-i2 (rem (ash (funcall (hash-table-sxhash hash-table) key) 1) bucket-length)) (i2 start-i2)) (do () (nil) @@ -144,7 +144,7 @@ "Assuming hash-tables keys are lists whose elements compare by EQ, look up key0 as if it was in a singleton list (key0)." (let* ((bucket (hash-table-bucket hash-table)) - (bucket-length (vector-dimension bucket)) + (bucket-length (array-dimension bucket 0)) (start-i2 (rem (ash (sxhash-eq key0) 1) bucket-length)) (i2 start-i2)) (do () (nil) @@ -161,7 +161,7 @@ "Assuming hash-tables keys are lists whose elements compare by EQ, look up key0 and key1 as if they were in a doubleton list (key0 key1)." (let* ((bucket (hash-table-bucket hash-table)) - (bucket-length (vector-dimension bucket)) + (bucket-length (array-dimension bucket 0)) (start-i2 (rem (ash (logxor (sxhash-eq key0) (sxhash-eq key1)) 1) bucket-length)) (i2 start-i2)) @@ -204,7 +204,7 @@ (svref%unsafe bucket index2)) (values default nil)) (when ;; (string= key-string (svref bucket index2) :start1 start :end1 end)) - (let* ((bs (svref%unsafe bucket index2)) + (let* ((bs (svref bucket index2)) (bs-length (length bs))) (and (= bs-length (- end start)) (do ((bs-index 0 (1+ bs-index)) From ffjeld at common-lisp.net Tue Jun 29 23:20:56 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 29 Jun 2004 16:20:56 -0700 Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11808 Modified Files: storage-types.lisp Log Message: More complete support for basic-vectors, such as proper methods for write-binary and read-binary. Date: Tue Jun 29 16:20:56 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.22 movitz/storage-types.lisp:1.23 --- movitz/storage-types.lisp:1.22 Thu Jun 17 02:49:08 2004 +++ movitz/storage-types.lisp Tue Jun 29 16:20:56 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.22 2004/06/17 09:49:08 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.23 2004/06/29 23:20:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -403,7 +403,9 @@ (num-elements :binary-type word :initarg :num-elements - :reader movitz-vector-num-elements) + :reader movitz-vector-num-elements + :map-binary-write 'movitz-read-and-intern + :map-binary-read-delayed 'movitz-word-and-print) (data :binary-lisp-type :label) ; data follows physically here (symbolic-data @@ -431,6 +433,13 @@ (movitz-read (svref vector i))))) (values)) +(defmethod update-movitz-object ((movitz-vector movitz-basic-vector) (vector vector)) + (when (eq :any-t (movitz-vector-element-type movitz-vector)) + (loop for i from 0 below (length vector) + do (setf (svref (movitz-vector-symbolic-data movitz-vector) i) + (movitz-read (svref vector i))))) + (values)) + (defmethod write-binary-record ((obj movitz-vector) stream) (flet ((write-element (type stream data) (ecase type @@ -450,6 +459,25 @@ with type = (movitz-vector-element-type obj) summing (write-element type stream data))))))) +(defmethod write-binary-record ((obj movitz-basic-vector) stream) + (flet ((write-element (type stream data) + (ecase type +;;; (:u8 (write-binary 'u8 stream data)) +;;; (:u16 (write-binary 'u16 stream data)) +;;; (:u32 (write-binary 'u32 stream data)) +;;; (:character (write-binary 'char8 stream data)) + (:any-t (write-binary 'word stream (movitz-read-and-intern data 'word)))))) + (+ (call-next-method) ; header + (etypecase (movitz-vector-symbolic-data obj) + (list + (loop for data in (movitz-vector-symbolic-data obj) + with type = (movitz-vector-element-type obj) + summing (write-element type stream data))) + (vector + (loop for data across (movitz-vector-symbolic-data obj) + with type = (movitz-vector-element-type obj) + summing (write-element type stream data))))))) + (defmethod read-binary-record ((type-name (eql 'movitz-vector)) stream &key &allow-other-keys) (let ((object (call-next-method))) (setf (movitz-vector-symbolic-data object) @@ -465,12 +493,33 @@ (movitz-word word))))))) object)) +(defmethod read-binary-record ((type-name (eql 'movitz-basic-vector)) stream &key &allow-other-keys) + (let ((object (call-next-method))) + (setf (movitz-vector-symbolic-data object) + (loop for i from 1 to (movitz-vector-num-elements object) + collecting + (ecase (movitz-vector-element-type object) + (:u8 (read-binary 'u8 stream)) + (:u16 (read-binary 'u16 stream)) + (:u32 (read-binary 'u32 stream)) + (:character (read-binary 'char8 stream)) + (:any-t (let ((word (read-binary 'word stream))) + (with-image-stream-position-remembered () + (movitz-word word))))))) + object)) + (defmethod sizeof ((object movitz-vector)) (+ (call-next-method) (ceiling (* (movitz-vector-element-type-size (slot-value object 'element-type)) (slot-value object 'num-elements)) 8))) +(defmethod sizeof ((object movitz-basic-vector)) + (+ (call-next-method) + (ceiling (* (movitz-vector-element-type-size (slot-value object 'element-type)) + (slot-value object 'num-elements)) + 8))) + (defmethod print-object ((obj movitz-vector) stream) (print-unreadable-movitz-object (obj stream :type nil :identity t) (case (movitz-vector-element-type obj) @@ -502,12 +551,12 @@ (t (values :any-t nil)))) (defun make-movitz-vector (size &key (element-type 'movitz-object) - (initial-contents nil) - (initial-element *movitz-nil* initial-element-p) - (alignment 8) - (alignment-offset 0) - (flags nil) - fill-pointer) + (initial-contents nil) + (initial-element *movitz-nil* initial-element-p) + (alignment 8) + (alignment-offset 0) + (flags nil) + fill-pointer) (assert (or (null initial-contents) (= size (length initial-contents))) (size initial-contents) "The initial-contents must be the same length as SIZE.") @@ -543,15 +592,28 @@ (setf initial-contents (make-array size :initial-element (or (and initial-element-p initial-element) default-element)))) - (make-instance 'movitz-vector - :element-type et - :num-elements size - :symbolic-data initial-contents ;; sv - :flags (union flags (if fill-pointer '(:fill-pointer-p) nil)) - :fill-pointer (if (integerp fill-pointer) fill-pointer size) - :alignment-power (dpb (- (truncate (log alignment 2)) 3) - (byte 4 4) - alignment-offset)))) + (cond + ((eq et :any-t) + (when flags (break "flags: ~S" flags)) + (when (and alignment-offset (plusp alignment-offset)) + (break "alignment: ~S" alignment-offset)) + (make-instance 'movitz-basic-vector + :element-type et + :num-elements size + :symbolic-data initial-contents ;; sv + :fill-pointer (* +movitz-fixnum-factor+ + (if (integerp fill-pointer) + fill-pointer + size)))) + (t (make-instance 'movitz-vector + :element-type et + :num-elements size + :symbolic-data initial-contents ;; sv + :flags (union flags (if fill-pointer '(:fill-pointer-p) nil)) + :fill-pointer (if (integerp fill-pointer) fill-pointer size) + :alignment-power (dpb (- (truncate (log alignment 2)) 3) + (byte 4 4) + alignment-offset)))))) (defun make-movitz-string (string) (make-movitz-vector (length string) @@ -1074,8 +1136,7 @@ (defmethod print-object ((object movitz-struct) stream) (print-unreadable-object (object stream :type t) - (format stream "~S" (and (slot-boundp object 'name) - (slot-value object 'name))))) + (format stream "~S" (slot-value object 'name)))) ;;; @@ -1226,7 +1287,7 @@ :initial-element nil)) (defun map-idt-to-array (idt type) - (check-type idt movitz-vector) + (check-type idt movitz-basic-vector) (assert (eq type 'word)) (let ((byte-list (with-binary-output-to-list (bytes) @@ -1297,7 +1358,7 @@ (*movitz-obj-no-recurse* t)) (declare (special *movitz-obj-no-recurse*)) (write-char #\space stream) - (write (aref (slot-value object 'slots) 0) + (write (aref (movitz-print (slot-value object 'slots)) 0) :stream stream)))) object) From ffjeld at common-lisp.net Tue Jun 29 23:21:28 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 29 Jun 2004 16:21:28 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13719 Modified Files: arrays.lisp Log Message: Minor edit. Date: Tue Jun 29 16:21:28 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.27 movitz/losp/muerte/arrays.lisp:1.28 --- movitz/losp/muerte/arrays.lisp:1.27 Wed Jun 23 03:15:10 2004 +++ movitz/losp/muerte/arrays.lisp Tue Jun 29 16:21:28 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.27 2004/06/23 10:15:10 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.28 2004/06/29 23:21:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -122,7 +122,7 @@ (assert (%basic-vector-has-fill-pointer-p vector) (vector) "Vector has no fill-pointer.") (%basic-vector-fill-pointer vector)) - (vector + (old-vector (memref vector #.(bt:slot-offset 'movitz:movitz-vector 'movitz::fill-pointer) 0 :unsigned-byte16))))