movitz-cvs April 2004

movitz-cvs@common-lisp.net

1 participants
210 discussions

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

01 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv20224 Modified Files: compiler.lisp Log Message: More stuff about using ECX only as a scratch register (i.e. it can't be used to hold pointer values that might be moved by GC). Date: Thu Apr 1 12:27:03 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.40 movitz/compiler.lisp:1.41 --- movitz/compiler.lisp:1.40 Wed Mar 31 21:09:26 2004 +++ movitz/compiler.lisp Thu Apr 1 12:27:03 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.40 2004/04/01 02:09:26 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.41 2004/04/01 17:27:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2433,7 +2433,7 @@ pos))))) (defun compute-free-registers (pc distance funobj frame-map - &key (free-registers '(:eax :ebx :ecx :edx))) + &key (free-registers '(:ecx :eax :ebx :edx))) "Return set of free register, and whether there may be more registers free later, with a more specified frame-map." (loop with free-so-far = free-registers @@ -2518,22 +2518,35 @@ (distance (position load-instruction (cdr init-pc)))) (multiple-value-bind (free-registers more-later-p) (and distance (compute-free-registers (cdr init-pc) distance funobj frame-map)) - (if (and (member :ecx free-registers) + (let ((free-registers-no-ecx (remove :ecx free-registers))) + (cond + ((member binding-destination free-registers-no-ecx) + binding-destination) + ((and (not (typep binding '(or fixed-required-function-argument + register-required-function-argument))) + (member binding-destination free-registers)) + binding-destination) + ((member init-with-register free-registers) + init-with-register) + ((and (member :ecx free-registers) (not (typep binding 'function-argument)) (or (eq :untagged-fixnum-ecx binding-destination) (eq :untagged-fixnum-ecx init-with-register))) - :untagged-fixnum-ecx - (let ((free-registers (remove :ecx free-registers))) - (cond - ((member binding-destination free-registers) - binding-destination) - ((member init-with-register free-registers) - init-with-register) - ((not (null free-registers)) - (first free-registers)) - (more-later-p - (values nil :not-now)) - (t (values nil :never))))))))) + :untagged-fixnum-ecx) + ((and (binding-store-type binding) + (member :ecx free-registers) + (not (typep binding '(or fixed-required-function-argument + register-required-function-argument))) + (multiple-value-call #'encoded-subtypep + (values-list (binding-store-type binding)) + (type-specifier-encode '(or integer character)))) + (warn "for ecX: ~S" binding) + :ecx) + ((not (null free-registers-no-ecx)) + (first free-registers-no-ecx)) + (more-later-p + (values nil :not-now)) + (t (values nil :never)))))))) (t (values nil :never))))) (defun discover-variables (code function-env) @@ -3050,7 +3063,7 @@ ((:eax :single-value) nil) (:untagged-fixnum-ecx `((:movl :eax :ecx) - (:sarl ,movitz:+movitz-fixnum-factor+ :ecx))))) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx))))) ((:ebx :ecx :edx) (assert (not indirect-p)) (unless (eq result-mode lexb-location) @@ -3059,7 +3072,7 @@ ((:ebx :ecx :edx :esi) `((:movl ,lexb-location ,result-mode))) (:untagged-fixnum-ecx `((:movl ,lexb-location :ecx) - (:sarl ,movitz:+movitz-fixnum-factor+ :ecx)))))) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)))))) (:argument-stack (assert (<= 2 (function-argument-argnum lexb)) () "lexical :argument-stack argnum can't be ~A." (function-argument-argnum lexb)) @@ -3132,8 +3145,6 @@ `((:movl (:ebp ,(stack-frame-offset binding-location)) :eax) (:pushl (:eax -1))) (ecase binding-location -;;; (:eax '((:pushl :eax))) -;;; (:ebx '((:pushl :ebx))) (:argument-stack (assert (<= 2 (function-argument-argnum binding)) () ":load-lexical argnum can't be ~A." (function-argument-argnum binding)) @@ -3150,8 +3161,8 @@ (if (integerp binding-location) `((:pushl (:ebp ,(stack-frame-offset binding-location)))) (ecase binding-location - (:eax '((:pushl :eax))) - (:ebx '((:pushl :ebx))) + ((:eax :ebx :ecx :edx) + `((:pushl ,binding-location))) (:argument-stack (assert (<= 2 (function-argument-argnum binding)) () ":load-lexical argnum can't be ~A." (function-argument-argnum binding)) @@ -3254,7 +3265,7 @@ (if (integerp location) `((:movl ,source (:ebp ,(stack-frame-offset location)))) (ecase location - ((:eax :ebx :edx) + ((:eax :ebx :ecx :edx) (unless (eq source location) `((:movl ,source ,location)))) (:argument-stack

1 0

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

01 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv17689 Modified Files: compiler-types.lisp Log Message: Don't forget the character type. Date: Thu Apr 1 12:26:04 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.8 movitz/compiler-types.lisp:1.9 --- movitz/compiler-types.lisp:1.8 Sat Feb 14 17:47:25 2004 +++ movitz/compiler-types.lisp Thu Apr 1 12:26:04 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.8 2004/02/14 22:47:25 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.9 2004/04/01 17:26:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -423,7 +423,7 @@ (cond ((atom type-specifier) (case type-specifier - ((t nil cons symbol keyword function array vector integer hash-table) + ((t nil cons symbol keyword function array vector integer hash-table character) (type-values type-specifier)) (null (type-values () :members '(nil)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/eval.lisp
by Frode Vatvedt Fjeld 01 Apr '04

01 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2560 Modified Files: eval.lisp Log Message: Added a mock compile function. Date: Thu Apr 1 11:07:37 2004 Author: ffjeld Index: movitz/losp/muerte/eval.lisp diff -u movitz/losp/muerte/eval.lisp:1.3 movitz/losp/muerte/eval.lisp:1.4 --- movitz/losp/muerte/eval.lisp:1.3 Sun Mar 28 08:23:57 2004 +++ movitz/losp/muerte/eval.lisp Thu Apr 1 11:07:37 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.3 2004/03/28 13:23:57 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.4 2004/04/01 16:07:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -388,3 +388,13 @@ (apply (lookup-setf-function (caar p)) (eval-form value-form env) place-subvalues))))))) + +(defun compile (name &optional definition) + "=> function, warnings-p, failure-p" + (let ((function (eval (or definition (symbol-function name))))) + (check-type function function) + (warn ";; There is no real compiler here.") + (values (if (not name) + function + (setf (symbol-function name) function)) + t nil))) \ No newline at end of file

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/textmode.lisp
by Frode Vatvedt Fjeld 01 Apr '04

01 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv4971 Modified Files: textmode.lisp Log Message: Some minor code tuneups. Date: Wed Mar 31 21:15:22 2004 Author: ffjeld Index: movitz/losp/x86-pc/textmode.lisp diff -u movitz/losp/x86-pc/textmode.lisp:1.3 movitz/losp/x86-pc/textmode.lisp:1.4 --- movitz/losp/x86-pc/textmode.lisp:1.3 Mon Jan 19 06:23:52 2004 +++ movitz/losp/x86-pc/textmode.lisp Wed Mar 31 21:15:21 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 9 15:38:56 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: textmode.lisp,v 1.3 2004/01/19 11:23:52 ffjeld Exp $ +;;;; $Id: textmode.lisp,v 1.4 2004/04/01 02:15:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -45,7 +45,7 @@ (defun (setf cursor-row) (value &optional device) (declare (ignore device)) (setf *cursor-y* value) - (move-vga-cursor *cursor-x* *cursor-y*) + (move-vga-cursor *cursor-x* value) value) (defun cursor-column (&optional device) @@ -55,7 +55,7 @@ (defun (setf cursor-column) (value &optional device) (declare (ignore device)) (setf *cursor-x* value) - (move-vga-cursor *cursor-x* *cursor-y*) + (move-vga-cursor value *cursor-y*) value) (defun textmode-write-char (c) @@ -80,9 +80,9 @@ (cond ((= *screen-height* *cursor-y*) (textmode-scroll-down) - (move-vga-cursor *cursor-x* *cursor-y*)) + (move-vga-cursor 0 *cursor-y*)) (t (incf *cursor-y*) - (move-vga-cursor *cursor-x* *cursor-y*)))) + (move-vga-cursor 0 *cursor-y*)))) (#\backspace (if (/= 0 *cursor-x*) (decf *cursor-x*) @@ -92,18 +92,20 @@ (move-vga-cursor *cursor-x* *cursor-y*)) (#\return (setf *cursor-x* 0) - (move-vga-cursor *cursor-x* *cursor-y*)) + (move-vga-cursor 0 *cursor-y*)) (#\tab (textmode-write-char #\space) (do () ((zerop (rem *cursor-x* 8))) (textmode-write-char #\space))) - (t (when (>= *cursor-x* *screen-width*) - (textmode-write-char #\newline)) - (let ((index (+ *cursor-x* (* *cursor-y* *screen-stride*)))) - (setf (memref-int *screen* 0 index :unsigned-byte16 t) - (logior #x0700 (char-code c))) - (incf *cursor-x*) - (move-vga-cursor *cursor-x* *cursor-y*)))))) + (t (let ((x *cursor-x*) + (y *cursor-y*)) + (when (>= x *screen-width*) + (textmode-write-char #\newline) + (setf x *cursor-x* y *cursor-y*)) + (let ((index (+ x (* y *screen-stride*)))) + (setf (memref-int *screen* 0 index :unsigned-byte16 t) + (logior #x0700 (char-code c))) + (move-vga-cursor (setf *cursor-x* (1+ x)) y))))))) nil) (defun textmode-scroll-down () @@ -128,7 +130,6 @@ (:subl 1 :ecx) (:jnz 'clear-loop))) - (defun textmode-clear-line (from-column line) (let ((dest (+ *screen* (* line 80 2) (* from-column 2)))) (dotimes (i (- 80 from-column))

1 0

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

01 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv14478 Modified Files: memref.lisp Log Message: Some tuning of memref. Date: Wed Mar 31 21:13:30 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.8 movitz/losp/muerte/memref.lisp:1.9 --- movitz/losp/muerte/memref.lisp:1.8 Wed Mar 31 16:35:27 2004 +++ movitz/losp/muerte/memref.lisp Wed Mar 31 21:13:27 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.8 2004/03/31 21:35:27 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.9 2004/04/01 02:13:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -65,8 +65,7 @@ (:movzxb (:eax ,(offset-by 1)) :ecx))) ((eq 0 offset) `(with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-two-forms (:eax :ecx) ,object ,index) - (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:compile-two-forms (:eax :untagged-fixnum-ecx) ,object ,index) (:movzxb (:eax :ecx ,(offset-by 1)) :ecx))) (t (let ((object-var (gensym "memref-object-"))) `(let ((,object-var ,object)) @@ -156,15 +155,11 @@ ((and (eq 0 offset) (eq 0 index)) `(with-inline-assembly (:returns :untagged-fixnum-ecx) (:compile-form (:result-mode :eax) ,object) - (:movl (:eax ,(offset-by 4)) :ecx) - (:cmpl ,movitz::+movitz-most-positive-fixnum+ :ecx) - (:jg '(:sub-program () (:int 4))))) + (:movl (:eax ,(offset-by 4)) :ecx))) ((eq 0 offset) `(with-inline-assembly (:returns :untagged-fixnum-ecx) (:compile-two-forms (:eax :ecx) ,object ,index) - (:movl (:eax :ecx ,(offset-by 4)) :ecx) - (:cmpl ,movitz::+movitz-most-positive-fixnum+ :ecx) - (:jg '(:sub-program () (:int 4))))) + (:movl (:eax :ecx ,(offset-by 4)) :ecx))) (t (let ((object-var (gensym "memref-object-"))) `(let ((,object-var ,object)) (with-inline-assembly (:returns :untagged-fixnum-ecx) @@ -269,8 +264,7 @@ ((and (movitz:movitz-constantp offset env) (movitz:movitz-constantp index env)) `(with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-two-forms (:ecx :ebx) ,value ,object) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,value ,object) (:movl :ecx (:ebx ,(+ (movitz:movitz-eval offset env) (* 4 (movitz:movitz-eval index env))))))) ((and (movitz:movitz-constantp offset env) @@ -317,8 +311,7 @@ ((and (movitz:movitz-constantp offset env) (movitz:movitz-constantp index env)) `(with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-two-forms (:ecx :ebx) ,value ,object) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,value ,object) (:movw :cx (:ebx ,(+ (movitz:movitz-eval offset env) (* 2 (movitz:movitz-eval index env))))))) ((and (movitz:movitz-constantp offset env)

1 0

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

01 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10081 Modified Files: integers.lisp Log Message: Changed logbitp somewhat. Date: Wed Mar 31 21:12:22 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.3 movitz/losp/muerte/integers.lisp:1.4 --- movitz/losp/muerte/integers.lisp:1.3 Thu Feb 26 08:46:36 2004 +++ movitz/losp/muerte/integers.lisp Wed Mar 31 21:12: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.3 2004/02/26 13:46:36 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.4 2004/04/01 02:12:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -846,10 +846,14 @@ (defun logbitp (index integer) (check-type integer fixnum) (with-inline-assembly (:returns :boolean-cf=1) - (:compile-form (:result-mode :eax) integer) - (:compile-form (:result-mode :untagged-fixnum-ecx) index) + (:compile-two-forms (:eax :ebx) index integer) + (:testl #x80000003 :eax) + (:jnz '(:sub-program () + (:int 66))) + (:movl :eax :ecx) + (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) (:addl #.movitz::+movitz-fixnum-shift+ :ecx) - (:btl :ecx :eax))) + (:btl :ecx :ebx))) (define-compiler-macro logbitp (&whole form index integer &environment env) (if (not (movitz:movitz-constantp index env))

1 0

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

01 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5750 Modified Files: inspect.lisp Log Message: Minor code-tuneup. Date: Wed Mar 31 21:11:48 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.6 movitz/losp/muerte/inspect.lisp:1.7 --- movitz/losp/muerte/inspect.lisp:1.6 Mon Mar 29 10:26:25 2004 +++ movitz/losp/muerte/inspect.lisp Wed Mar 31 21:11:48 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.6 2004/03/29 15:26:25 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.7 2004/04/01 02:11:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -87,8 +87,9 @@ (defun stack-ref-p (pointer) (let ((top (load-global-constant-u32 stack-top)) - (bottom (with-inline-assembly (:returns :untagged-fixnum-ecx) - (:movl :esp :ecx)))) + (bottom (with-inline-assembly (:returns :eax) + (:movl :esp :eax) + (:shll #.movitz:+movitz-fixnum-shift+ :eax)))) (<= bottom pointer top))) (defun stack-ref (pointer offset index type)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.lisp
by Frode Vatvedt Fjeld 01 Apr '04

01 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv960 Modified Files: basic-functions.lisp Log Message: Prefer EDX over ECX as temporary register. Date: Wed Mar 31 21:10:38 2004 Author: ffjeld Index: movitz/losp/muerte/basic-functions.lisp diff -u movitz/losp/muerte/basic-functions.lisp:1.8 movitz/losp/muerte/basic-functions.lisp:1.9 --- movitz/losp/muerte/basic-functions.lisp:1.8 Mon Mar 29 09:32:40 2004 +++ movitz/losp/muerte/basic-functions.lisp Wed Mar 31 21:10:38 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.8 2004/03/29 14:32:40 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.9 2004/04/01 02:10:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -117,12 +117,13 @@ (:call (:esi #.(movitz::slot-offset 'movitz::movitz-funobj 'movitz::code-vector%2op))))) ((not (next x)) ; 3 args (with-inline-assembly (:returns :multiple-values) - (:compile-form (:result-mode :ecx) args) - (:movl (:ecx -1) :eax) ; arg0 - (:movl (:ecx 3) :ecx) ; ecx = (cdr ebx) - (:movl (:ecx -1) :ebx) ; ecx = (car ebx) = arg1 - (:movl (:ecx 3) :ecx) ; ecx = (cdr ebx) - (:pushl (:ecx -1)) ; arg2 + (:compile-form (:result-mode :edx) args) + (:movl (:edx -1) :eax) ; arg0 + (:movl (:edx 3) :edx) ; edx = (cdr ebx) + (:movl (:edx -1) :ebx) ; edx = (car ebx) = arg1 + (:movl (:edx 3) :edx) ; edx = (cdr ebx) + (:pushl (:edx -1)) ; arg2 + (:compile-form (:result-mode :edx) function-or-name) (:compile-form (:result-mode :esi) function) (:call (:esi #.(movitz::slot-offset 'movitz::movitz-funobj 'movitz::code-vector%3op))))) (t (with-inline-assembly (:returns :multiple-values)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp
by Frode Vatvedt Fjeld 01 Apr '04

01 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv20939 Modified Files: arrays.lisp Log Message: Minor edit. Date: Wed Mar 31 21:09:58 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.15 movitz/losp/muerte/arrays.lisp:1.16 --- movitz/losp/muerte/arrays.lisp:1.15 Wed Mar 31 11:39:38 2004 +++ movitz/losp/muerte/arrays.lisp Wed Mar 31 21:09:58 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.15 2004/03/31 16:39:38 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.16 2004/04/01 02:09:58 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -106,7 +106,7 @@ (defun fill-pointer (vector) (check-type vector vector) - (memref vector #.(bt:slot-offset 'movitz::movitz-vector 'movitz::fill-pointer) 0 + (memref vector #.(bt:slot-offset 'movitz:movitz-vector 'movitz::fill-pointer) 0 :unsigned-byte16))

1 0

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

01 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv20779 Modified Files: compiler.lisp Log Message: These changes are mostly about being more consistent about using ECX as a scratch (non-GC-root) register. Date: Wed Mar 31 21:09:26 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.39 movitz/compiler.lisp:1.40 --- movitz/compiler.lisp:1.39 Wed Mar 31 10:55:31 2004 +++ movitz/compiler.lisp Wed Mar 31 21:09:26 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.39 2004/03/31 15:55:31 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.40 2004/04/01 02:09:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2095,8 +2095,8 @@ (binding-name object) (unless (eq object (binding-target object)) (binding-name (binding-target object))) - (when (and (slot-exists-p object 'store-type) - (slot-boundp object 'store-type) + (when (and #+ignore (slot-exists-p object 'store-type) + #+ignore (slot-boundp object 'store-type) (binding-store-type object)) (apply #'encoded-type-decode (binding-store-type object))))))) @@ -2107,6 +2107,9 @@ :reader constant-object))) (defmethod binding-lended-p ((binding constant-object-binding)) nil) +(defmethod binding-store-type ((binding constant-object-binding)) + (multiple-value-list (type-specifier-encode `(eql ,(constant-object binding))))) + (defclass operator-binding (binding) ()) @@ -2430,7 +2433,7 @@ pos))))) (defun compute-free-registers (pc distance funobj frame-map - &key (free-registers '(:eax :ebx :edx))) + &key (free-registers '(:eax :ebx :ecx :edx))) "Return set of free register, and whether there may be more registers free later, with a more specified frame-map." (loop with free-so-far = free-registers @@ -2515,16 +2518,22 @@ (distance (position load-instruction (cdr init-pc)))) (multiple-value-bind (free-registers more-later-p) (and distance (compute-free-registers (cdr init-pc) distance funobj frame-map)) - (cond - ((member binding-destination free-registers) - binding-destination) - ((member init-with-register free-registers) - init-with-register) - ((not (null free-registers)) - (first free-registers)) - (more-later-p - (values nil :not-now)) - (t (values nil :never))))))) + (if (and (member :ecx free-registers) + (not (typep binding 'function-argument)) + (or (eq :untagged-fixnum-ecx binding-destination) + (eq :untagged-fixnum-ecx init-with-register))) + :untagged-fixnum-ecx + (let ((free-registers (remove :ecx free-registers))) + (cond + ((member binding-destination free-registers) + binding-destination) + ((member init-with-register free-registers) + init-with-register) + ((not (null free-registers)) + (first free-registers)) + (more-later-p + (values nil :not-now)) + (t (values nil :never))))))))) (t (values nil :never))))) (defun discover-variables (code function-env) @@ -3000,6 +3009,14 @@ &key tmp-register protect-registers) "When tmp-register is provided, use that for intermediate storage required when loading borrowed bindings." + #+ignore + (when (eq :ecx result-mode) + ;; (warn "loading to ecx: ~S" binding) + (unless (or (null (binding-store-type binding)) + (movitz-subtypep (apply #'encoded-type-decode + (binding-store-type binding)) + 'integer)) + (warn "ecx from ~S" binding))) (when (movitz-env-get (binding-name binding) 'ignore nil (binding-env binding)) (warn "The variable ~S is used even if it was declared ignored." (binding-name binding))) @@ -3012,32 +3029,56 @@ protect-registers)) (error "Unable to chose a temporary register."))) (install-for-single-value (lexb lexb-location result-mode indirect-p) - (if (integerp lexb-location) - (append `((:movl ,(make-indirect-reference :ebp (stack-frame-offset lexb-location)) - ,(single-value-register result-mode))) - (when indirect-p - `((:movl (-1 ,(single-value-register result-mode)) - ,(single-value-register result-mode))))) - (ecase lexb-location - (:eax - (assert (not indirect-p)) - (ecase result-mode - ((:ebx :ecx :edx :esi) `((:movl :eax ,result-mode))) - ((:eax :single-value) nil))) - ((:ebx :ecx :edx) - (assert (not indirect-p)) - (unless (eq result-mode lexb-location) + (cond + ((and (eq result-mode :untagged-fixnum-ecx) + (integerp lexb-location)) + (assert (not indirect-p)) + `((:movl ,(make-indirect-reference :ebp (stack-frame-offset lexb-location)) + :ecx) + (:sarl ,+movitz-fixnum-shift+ :ecx))) + ((integerp lexb-location) + (append `((:movl ,(make-indirect-reference :ebp (stack-frame-offset lexb-location)) + ,(single-value-register result-mode))) + (when indirect-p + `((:movl (-1 ,(single-value-register result-mode)) + ,(single-value-register result-mode)))))) + (t (ecase lexb-location + (:eax + (assert (not indirect-p)) (ecase result-mode - ((:eax :single-value) `((:movl ,lexb-location :eax))) - ((:ebx :ecx :edx :esi) `((:movl ,lexb-location ,result-mode)))))) - (:argument-stack - (assert (<= 2 (function-argument-argnum lexb)) () - "lexical :argument-stack argnum can't be ~A." (function-argument-argnum lexb)) - (append `((:movl (:ebp ,(argument-stack-offset lexb)) - ,(single-value-register result-mode))) - (when indirect-p - `((:movl (-1 ,(single-value-register result-mode)) - ,(single-value-register result-mode)))))))))) + ((:ebx :ecx :edx :esi) `((:movl :eax ,result-mode))) + ((:eax :single-value) nil) + (:untagged-fixnum-ecx + `((:movl :eax :ecx) + (:sarl ,movitz:+movitz-fixnum-factor+ :ecx))))) + ((:ebx :ecx :edx) + (assert (not indirect-p)) + (unless (eq result-mode lexb-location) + (ecase result-mode + ((:eax :single-value) `((:movl ,lexb-location :eax))) + ((:ebx :ecx :edx :esi) `((:movl ,lexb-location ,result-mode))) + (:untagged-fixnum-ecx + `((:movl ,lexb-location :ecx) + (:sarl ,movitz:+movitz-fixnum-factor+ :ecx)))))) + (:argument-stack + (assert (<= 2 (function-argument-argnum lexb)) () + "lexical :argument-stack argnum can't be ~A." (function-argument-argnum lexb)) + (cond + ((eq result-mode :untagged-fixnum-ecx) + (assert (not indirect-p)) + `((:movl (:ebp ,(argument-stack-offset lexb)) :ecx) + (:sarl ,+movitz-fixnum-shift+ :ecx))) + (t (append `((:movl (:ebp ,(argument-stack-offset lexb)) + ,(single-value-register result-mode))) + (when indirect-p + `((:movl (-1 ,(single-value-register result-mode)) + ,(single-value-register result-mode)))))))) + (:untagged-fixnum-ecx + (ecase result-mode + ((:eax :ebx :ecx :edx) + `((:leal ((:ecx ,+movitz-fixnum-factor+)) ,result-mode))) + (:untagged-fixnum-ecx + nil)))))))) (etypecase binding (forwarding-binding (assert (not (binding-lended-p binding)) (binding) @@ -3138,9 +3179,7 @@ `((:cmpl :edi (:ebp ,(argument-stack-offset binding))) (:je ',(operands result-mode))))))) (:untagged-fixnum-ecx - (make-result-and-returns-glue - result-mode :ecx - (install-for-single-value binding binding-location :ecx nil))) + (install-for-single-value binding binding-location :untagged-fixnum-ecx nil)) (:lexical-binding (let* ((destination result-mode) (dest-location (new-binding-location destination frame-map :default nil))) @@ -3174,6 +3213,13 @@ "funny binding: ~W" binding) (let ((protect-registers (cons source protect-registers))) (cond + ((eq :untagged-fixnum-ecx source) + (if (eq :untagged-fixnum-ecx + (new-binding-location binding frame-map)) + nil + (append (make-result-and-returns-glue :ecx :untagged-fixnum-ecx) + (make-store-lexical binding :ecx shared-reference-p frame-map + :protect-registers protect-registers)))) ((typep binding 'borrowed-binding) (let ((slot (borrowed-binding-reference-slot binding))) (if (not shared-reference-p) @@ -3214,7 +3260,12 @@ (:argument-stack (assert (<= 2 (function-argument-argnum binding)) () "store-lexical argnum can't be ~A." (function-argument-argnum binding)) - `((:movl ,source (:ebp ,(argument-stack-offset binding)))))))))))) + `((:movl ,source (:ebp ,(argument-stack-offset binding))))) + (:untagged-fixnum-ecx + (append (unless (member source '(:ecx :untagged-fixnum-ecx)) + `((:movl ,source :ecx))) + (unless (eq source :untagged-fixnum-ecx) + `((:sarl ,+movitz-fixnum-shift+ :ecx)))))))))))) (defun finalize-code (code funobj frame-map) ;; (print-code 'to-be-finalized code) @@ -4631,7 +4682,10 @@ (:untagged-fixnum-ecx (case (result-mode-type desired-result) ((:eax :ebx :ecx :edx) - (values (append code `((:leal ((:ecx ,+movitz-fixnum-factor+) :edi ,(edi-offset)) + (values (append code `((:cmpl ,+movitz-most-positive-fixnum+ :ecx) + (:ja '(:sub-program () + (:int 4))) + (:leal ((:ecx ,+movitz-fixnum-factor+) :edi ,(edi-offset)) ,desired-result))) desired-result)) (t (make-result-and-returns-glue desired-result :eax @@ -4695,7 +4749,7 @@ (compiler-call #'compile-form :result-mode :ebx :forward form-info)) - ((member form-returns '(:eax :ebx :ecx :edx :edi)) + ((member form-returns '(:eax :ebx :ecx :edx :edi :untagged-fixnum-ecx)) (compiler-values (unprotected-values))) (t (compiler-call #'compile-form :result-mode :eax

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs April 2004