movitz-cvs July 2004

movitz-cvs@common-lisp.net

2 participants
376 discussions

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

12 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv10562 Modified Files: textmode.lisp Log Message: Added the idea that condition "newline" is signalled whenever the console scrolls down. This can be used e.g. to implement :more in los0.lisp. Date: Mon Jul 12 00:57:52 2004 Author: ffjeld Index: movitz/losp/x86-pc/textmode.lisp diff -u movitz/losp/x86-pc/textmode.lisp:1.6 movitz/losp/x86-pc/textmode.lisp:1.7 --- movitz/losp/x86-pc/textmode.lisp:1.6 Wed Apr 21 09:24:10 2004 +++ movitz/losp/x86-pc/textmode.lisp Mon Jul 12 00:57:52 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.6 2004/04/21 16:24:10 ffjeld Exp $ +;;;; $Id: textmode.lisp,v 1.7 2004/07/12 07:57:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -69,12 +69,12 @@ (defun textmode-write-char (c) (case c (#\newline - (setf *cursor-x* 0) (cond ((>= (1+ *cursor-y*) *screen-height*) (textmode-scroll-down) (setf *cursor-y* (1- *screen-height*))) (t (incf *cursor-y*))) + (setf *cursor-x* 0) (move-vga-cursor 0 *cursor-y*)) (#\backspace (if (/= 0 *cursor-x*) @@ -125,6 +125,7 @@ (defun textmode-scroll-down () (declare (special muerte.lib::*scroll-offset*)) + (signal 'newline) (incf muerte.lib::*scroll-offset*) (loop with stride = (* 2 *screen-stride*) for y below *screen-height*

1 0

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

12 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6681 Modified Files: scavenge.lisp Log Message: Tweaks to map-heap-words, added some invariant assertions. Date: Mon Jul 12 00:56:45 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.13 movitz/losp/muerte/scavenge.lisp:1.14 --- movitz/losp/muerte/scavenge.lisp:1.13 Wed Jul 7 10:37:25 2004 +++ movitz/losp/muerte/scavenge.lisp Mon Jul 12 00:56:45 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.13 2004/07/07 17:37:25 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.14 2004/07/12 07:56:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -27,6 +27,7 @@ ;; circumstances, i.e. when you know there is no outside GC ;; etc. involved. +(defvar *scan*) (defun map-heap-words (function start-location end-location) "Map function over each potential pointer word between @@ -49,11 +50,13 @@ (:compile-form (:result-mode :eax) ,x) (:andl #xffff0000 :eax) (:shrl ,(- 16 movitz:+movitz-fixnum-shift+) :eax)))) - (do ((scan start-location (1+ scan))) + (do ((*scan-last* nil) ; Last scanned object, for debugging. + (scan start-location (1+ scan))) ((>= scan end-location)) - (let (;; (*i* i) + (declare (special *scan-last*)) + (let ((*scan* scan) (x (memref scan 0 0 :lisp))) - ;; (declare (special *i*)) + (declare (special *scan*)) (cond ((typep x '(or null fixnum character))) ((scavenge-typep x :illegal) @@ -64,10 +67,12 @@ ;; Just skip the bigits (let* ((bigits (word-upper16 x)) (delta (1+ (logand bigits -2)))) + (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) (incf scan delta))) ((scavenge-typep x :funobj) (assert (evenp scan) () "Scanned #x~Z at odd address #x~X." x scan) + (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) ;; Process code-vector pointer specially.. (let* ((funobj (%word-offset scan #.(movitz:tag :other))) (code-vector (funobj-code-vector funobj)) @@ -86,8 +91,6 @@ (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)) - ((scavenge-typep x :old-vector) - (error "Scanned old-vector #x~Z at odd address #x~X." x scan)) ((or (scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u8)) (scavenge-wide-typep x :basic-vector @@ -97,18 +100,29 @@ (assert (evenp scan) () "Scanned #x~Z at odd address #x~X." x scan) (let ((len (memref scan 0 1 :lisp))) - ;; (warn "scavenge at #x~X u8 vector len ~D." scan len) + (check-type len positive-fixnum) + (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) (incf scan (1+ (* 2 (truncate (+ 7 len) 8)))))) ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16)) (assert (evenp scan) () "Scanned #x~Z at odd address #x~X." x scan) (let ((len (memref scan 0 1 :lisp))) + (check-type len positive-fixnum) + (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) (incf scan (1+ (* 2 (truncate (+ 3 len) 4)))))) ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32)) (assert (evenp scan) () "Scanned #x~Z at odd address #x~X." x scan) (let ((len (memref scan 0 1 :lisp))) + (check-type len positive-fixnum) + (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) (incf scan (1+ (logand (1+ len) -2))))) + ((and (scavenge-typep x :basic-vector) + (not (scavenge-wide-typep x :basic-vector + #.(bt:enum-value 'movitz:movitz-vector-element-type :any-t)))) + (error "Scanned unknown basic-vector #x~Z at address #x~X." x scan)) + ((scavenge-typep x :old-vector) + (error "Scanned old-vector #x~Z at address #x~X." x scan)) ((eq x (fixnum-word 3)) (incf scan) (incf scan (memref scan 0 0 :lisp)))

1 0

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

12 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv20175 Modified Files: conditions.lisp Log Message: Added condition "newline". Date: Mon Jul 12 00:54:30 2004 Author: ffjeld Index: movitz/losp/muerte/conditions.lisp diff -u movitz/losp/muerte/conditions.lisp:1.7 movitz/losp/muerte/conditions.lisp:1.8 --- movitz/losp/muerte/conditions.lisp:1.7 Thu Jun 10 05:07:02 2004 +++ movitz/losp/muerte/conditions.lisp Mon Jul 12 00:54:30 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.7 2004/06/10 12:07:02 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.8 2004/07/12 07:54:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -303,3 +303,5 @@ (or format-control "Break was invoked.") format-arguments))) nil) + +(define-condition newline () ())

1 0

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

11 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5941 Modified Files: integers.lisp Log Message: Fixed logand and logior for bignums. Date: Sun Jul 11 16:05:24 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.42 movitz/losp/muerte/integers.lisp:1.43 --- movitz/losp/muerte/integers.lisp:1.42 Sat Jul 10 07:39:28 2004 +++ movitz/losp/muerte/integers.lisp Sun Jul 11 16:05: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.42 2004/07/10 14:39:28 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.43 2004/07/11 23:05:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1469,35 +1469,29 @@ (:btl ,(+ index movitz::+movitz-fixnum-shift+) :eax))))) -(defun logand%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))) - (:andl :ebx :eax))) - -(define-compiler-macro logand%2op (&whole form x y) - (cond - ((and (movitz:movitz-constantp x) (movitz:movitz-constantp y)) - (logand (movitz::movitz-eval x) (movitz::movitz-eval y))) - (t form))) - -(defun logand (&rest integers) - (declare (dynamic-extent integers)) - (if (null integers) - -1 - (reduce #'logand%2op integers))) +;;;(defun logand%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))) +;;; (:andl :ebx :eax))) +;;; +;;;(define-compiler-macro logand%2op (&whole form x y) +;;; (cond +;;; ((and (movitz:movitz-constantp x) (movitz:movitz-constantp y)) +;;; (logand (movitz::movitz-eval x) (movitz::movitz-eval y))) +;;; (t form))) -(define-compiler-macro logand (&whole form &rest integers) +(define-compiler-macro logand (&whole form &rest integers &environment env) (let ((constant-folded-integers (loop for x in integers with folded-constant = -1 - if (and (movitz:movitz-constantp x) - (not (= -1 (movitz::movitz-eval x)))) + if (and (movitz:movitz-constantp x env) + (not (= -1 (movitz:movitz-eval x env)))) do (setf folded-constant - (logand folded-constant (movitz::movitz-eval x))) + (logand folded-constant (movitz:movitz-eval x env))) else collect x into non-constants finally (return (if (= -1 folded-constant) non-constants @@ -1505,10 +1499,59 @@ (case (length constant-folded-integers) (0 0) (1 (first constant-folded-integers)) - (2 `(logand%2op ,(first constant-folded-integers) ,(second constant-folded-integers))) - (t `(logand (logand%2op ,(first constant-folded-integers) ,(second constant-folded-integers)) + (2 `(no-macro-call logand ,(first constant-folded-integers) ,(second constant-folded-integers))) + (t `(logand (logand ,(first constant-folded-integers) ,(second constant-folded-integers)) ,@(cddr constant-folded-integers)))))) +(defun logand (&rest integers) + (numargs-case + (1 (x) x) + (2 (x y) + (macrolet + ((do-it () + `(number-double-dispatch (x y) + ((fixnum fixnum) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) x y) + (:andl :ebx :eax))) + ((positive-bignum positive-fixnum) + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) x) + (:call-global-constant unbox-u32) + (:compile-form (:result-mode :eax) y) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :ecx) + (:andl :ecx :eax))) + ((positive-fixnum positive-bignum) + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) y) + (:call-global-constant unbox-u32) + (:compile-form (:result-mode :eax) x) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :ecx) + (:andl :ecx :eax))) + ((positive-bignum positive-bignum) + (if (< (%bignum-bigits y) (%bignum-bigits x)) + (logand y x) + (%bignum-canonicalize + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) (copy-bignum x) y) + (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) + :ecx) + (:leal ((:ecx 4) -4) :edx) + pb-pb-and-loop + (:movl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) + :ecx) + (:andl :ecx + (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:subl 4 :edx) + (:jnc 'pb-pb-and-loop))))) + ))) + (do-it))) + (t (&rest integers) + (declare (dynamic-extent integers)) + (if (null integers) + -1 + (reduce #'logand integers))))) + (defun logandc1 (integer1 integer2) (number-double-dispatch (integer1 integer2) ((t positive-fixnum) @@ -1518,34 +1561,10 @@ (: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) - (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))))) + (logandc1 integer2 integer1)) (defun logior (&rest integers) (numargs-case @@ -1633,20 +1652,20 @@ ((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) - (:xorl (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) :ecx))))) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ecx) (copy-bignum y) x) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:xorl :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) - (:xorl :ecx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))))) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ecx) (copy-bignum x) y) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:xorl :ecx + (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))))) (do-it))) ((positive-bignum positive-bignum) (if (< (%bignum-bigits x) (%bignum-bigits y))

1 0

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

11 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv29472 Modified Files: basic-macros.lisp Log Message: Include the :label argumet for with-inline-assembly. Date: Sun Jul 11 16:04:14 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.25 movitz/losp/muerte/basic-macros.lisp:1.26 --- movitz/losp/muerte/basic-macros.lisp:1.25 Wed Jul 7 10:37:30 2004 +++ movitz/losp/muerte/basic-macros.lisp Sun Jul 11 16:04:14 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.25 2004/07/07 17:37:30 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.26 2004/07/11 23:04:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -966,9 +966,9 @@ `(progn ,@body)) -(defmacro with-inline-assembly ((&key returns (side-effects t) (type t)) &body program) +(defmacro with-inline-assembly ((&key returns (side-effects t) (type t) labels) &body program) `(with-inline-assembly-case (:side-effects ,side-effects :type ,type) - (do-case (t ,returns) + (do-case (t ,returns :labels ,labels) ,@program))) (defmacro numargs-case (&rest args)

1 0

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

11 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv15296 Modified Files: basic-functions.lisp Log Message: Added operator object-tag. Date: Sun Jul 11 16:03:18 2004 Author: ffjeld Index: movitz/losp/muerte/basic-functions.lisp diff -u movitz/losp/muerte/basic-functions.lisp:1.11 movitz/losp/muerte/basic-functions.lisp:1.12 --- movitz/losp/muerte/basic-functions.lisp:1.11 Fri Apr 16 12:25:06 2004 +++ movitz/losp/muerte/basic-functions.lisp Sun Jul 11 16:03:18 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.11 2004/04/16 19:25:06 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.12 2004/07/11 23:03:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -340,6 +340,16 @@ (defun object-location (object) "The location is the object's address divided by fixnum-factor." (object-location object)) + +(define-compiler-macro object-tag (object) + `(with-inline-assembly (:returns :register :type (integer 0 7)) + (:compile-form (:result-mode :register) ,object) + (:leal (((:result-register) ,movitz::+movitz-fixnum-factor+)) + (:result-register)) + (:andl ,(* 7 movitz::+movitz-fixnum-factor+) (:result-register)))) + +(defun object-tag (object) + (object-tag object)) ;;;(define-compiler-macro object-location-offset (object) ;;; "The offset from the object's location to it's true address."

1 0

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

11 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12742 Modified Files: arrays.lisp Log Message: Fixed a nasty bug in (setf aref) for u32 vectors. Date: Sun Jul 11 16:02:33 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.34 movitz/losp/muerte/arrays.lisp:1.35 --- movitz/losp/muerte/arrays.lisp:1.34 Thu Jul 8 14:51:48 2004 +++ movitz/losp/muerte/arrays.lisp Sun Jul 11 16:02:33 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.34 2004/07/08 21:51:48 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.35 2004/07/11 23:02:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -337,7 +337,7 @@ (:cmpl ,(movitz:basic-vector-type-tag :u32) :ecx) (:jne 'not-u32-vector) (:call-global-constant unbox-u32) - (:movl :eax + (:movl :ecx (:ebx :edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) (:jmp 'return) @@ -628,7 +628,7 @@ (setf (fill-pointer array) length))) (cond (initial-element - (check-type initial-element (unsigned-byte 8)) + (check-type initial-element bit) (dotimes (i length) (setf (aref array i) initial-element))) (initial-contents

1 0

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

11 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1759 Modified Files: memref.lisp Log Message: Fixed (setf memref) for type :unsigned-byte32, which was completely bogus before. Date: Sun Jul 11 16:00:41 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.14 movitz/losp/muerte/memref.lisp:1.15 --- movitz/losp/muerte/memref.lisp:1.14 Sun Jun 6 04:32:09 2004 +++ movitz/losp/muerte/memref.lisp Sun Jul 11 16:00:41 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.14 2004/06/06 11:32:09 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.15 2004/07/11 23:00:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -326,12 +326,16 @@ (:movl ,value (:ebx :ecx ,(movitz:movitz-eval offset env)))) ,value))) ((movitz:movitz-constantp offset env) - (let ((value-var (gensym "memref-value-"))) - `(let ((,value-var ,value)) + (let ((value-var (gensym "memref-value-")) + (object-var (gensym "memref-object-")) + (index-var (gensym "memref-index-"))) + `(let ((,value-var ,value) + (,object-var ,object) + (,index-var ,index)) (with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-two-forms (:ebx :eax) ,object ,index) - (:load-lexical (:lexical-binding ,value-var) :ecx) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:call-global-constant unbox-u32) + (:compile-two-forms (:ebx :eax) ,object-var ,index-var) (:movl :ecx (:eax :ebx ,(movitz:movitz-eval offset env))))))) (t (let ((value-var (gensym "memref-value-")) (object-var (gensym "memref-object-")) @@ -342,14 +346,16 @@ (,object-var ,object) (,offset-var ,offset) (,index-var ,index)) - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:edx :untagged-fixnum-ecx) ,index-var ,offset-var) - (:addl :edx :ecx) ; offset+index in ECX - (:compile-two-forms (:eax :ebx) ,value-var ,object-var) + (with-inline-assembly (:returns :untagged-fixnum-ecx) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:call-global-constant unbox-u32) + (:compile-two-forms (:eax :edx) ,index-var ,offset-var) + (:load-lexical (:lexical-binding ,object-var) :ebx) (:std) - (:shrl ,movitz::+movitz-fixnum-shift+ :eax) - (:movl :eax (:ebx :ecx)) - (:shll ,movitz:+movitz-fixnum-shift+ :eax) + (:shrl ,movitz::+movitz-fixnum-shift+ :edx) + (:addl :eax :edx) ; EDX = offset+index + (:movl :ecx (:ebx :edx)) + (:movl :edi :edx) (:cld))))))) (:unsigned-byte16 (cond

1 0

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

11 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv8619 Modified Files: packages.lisp Log Message: More symbols. Date: Sun Jul 11 15:59:26 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.29 movitz/packages.lisp:1.30 --- movitz/packages.lisp:1.29 Thu Jul 8 11:53:29 2004 +++ movitz/packages.lisp Sun Jul 11 15:59:26 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.29 2004/07/08 18:53:29 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.30 2004/07/11 22:59:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1101,6 +1101,7 @@ print-word fixnump below print-unreadable-movitz-object + #:newline #:*print-safely* @@ -1159,6 +1160,7 @@ svref%unsafe bvref-u16 object-location + object-tag location-in-object-p inline-malloc define-compile-time-variable

1 0

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

11 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv30272 Modified Files: compiler.lisp Log Message: Fixed a nasty compiler bug. Function arguments located on the argument-stack would not be treated properly, e.g when copying one such variable to another. Date: Sun Jul 11 15:58:56 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.72 movitz/compiler.lisp:1.73 --- movitz/compiler.lisp:1.72 Sat Jul 10 06:29:11 2004 +++ movitz/compiler.lisp Sun Jul 11 15:58: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.72 2004/07/10 13:29:11 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.73 2004/07/11 22:58:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2399,7 +2399,10 @@ (list new-value) `(let ((,(car stores) (progn (assert (not (new-binding-located-p ,binding-var ,getter))) - (check-type ,new-value (or keyword binding (integer 0 *))) + (check-type ,new-value (or keyword + binding + (integer 0 *) + (cons (eql :argument-stack) *))) (acons ,binding-var ,new-value ,getter)))) ,setter ,new-value) @@ -2813,7 +2816,7 @@ (plusp (or (car (gethash binding var-counts)) 0))) (prog1 nil ; may need lending-cons (setf (new-binding-location binding frame-map) - :argument-stack))) + `(:argument-stack ,(function-argument-argnum binding))))) ((not (plusp (or (car (gethash binding var-counts)) 0))) (prog1 t (unless (or (movitz-env-get variable 'ignore nil env nil) @@ -2949,7 +2952,7 @@ (borrowed-binding) ; location is predetermined (fixed-required-function-argument (setf (new-binding-location binding frame-map) - :argument-stack)) + `(:argument-stack ,(function-argument-argnum binding)))) (located-binding (setf (new-binding-location binding frame-map) (post-incf stack-frame-position)))))) @@ -3228,7 +3231,7 @@ (when indirect-p `((:movl (-1 ,(single-value-register result-mode)) ,(single-value-register result-mode)))))) - (t (ecase lexb-location + (t (ecase (operator lexb-location) (:push (assert (member result-mode '(:eax :ebx :ecx :edx))) (assert (not indirect-p)) @@ -3324,7 +3327,7 @@ (if (integerp binding-location) `((:movl (:ebp ,(stack-frame-offset binding-location)) :eax) (:pushl (:eax -1))) - (ecase binding-location + (ecase (operator binding-location) (:argument-stack (assert (<= 2 (function-argument-argnum binding)) () ":load-lexical argnum can't be ~A." (function-argument-argnum binding)) @@ -3340,7 +3343,7 @@ (:push (if (integerp binding-location) `((:pushl (:ebp ,(stack-frame-offset binding-location)))) - (ecase binding-location + (ecase (operator binding-location) ((:eax :ebx :ecx :edx) `((:pushl ,binding-location))) (:argument-stack @@ -3351,7 +3354,7 @@ (if (integerp binding-location) `((:cmpl :edi (:ebp ,(stack-frame-offset binding-location))) (:jne ',(operands result-mode))) - (ecase binding-location + (ecase (operator binding-location) ((:eax :ebx) `((:cmpl :edi ,binding-location) (:jne ',(operands result-mode)))) @@ -3362,7 +3365,7 @@ (if (integerp binding-location) `((:cmpl :edi (:ebp ,(stack-frame-offset binding-location))) (:je ',(operands result-mode))) - (ecase binding-location + (ecase (operator binding-location) ((:eax :ebx) `((:cmpl :edi ,binding-location) (:je ',(operands result-mode)))) @@ -3378,7 +3381,7 @@ ((not dest-location) ; unknown, e.g. a borrowed-binding. (append (install-for-single-value binding binding-location :ecx nil) (make-store-lexical result-mode :ecx nil frame-map))) - ((eql binding-location dest-location) + ((equal binding-location dest-location) nil) ((member binding-location '(:eax :ebx :ecx :edx)) (make-store-lexical destination binding-location nil frame-map)) @@ -3435,7 +3438,7 @@ (if (integerp location) `((:movl (:ebp ,(stack-frame-offset location)) ,tmp-reg) (:movl ,source (,tmp-reg -1))) - (ecase location + (ecase (operator location) (:argument-stack (assert (<= 2 (function-argument-argnum binding)) () "store-lexical argnum can't be ~A." (function-argument-argnum binding)) @@ -3444,7 +3447,7 @@ (t (let ((location (new-binding-location binding frame-map))) (if (integerp location) `((:movl ,source (:ebp ,(stack-frame-offset location)))) - (ecase location + (ecase (operator location) ((:push) `((:pushl ,source))) ((:eax :ebx :ecx :edx) @@ -4091,7 +4094,7 @@ (typecase binding (required-function-argument ;; (warn "lend: ~W => ~W" binding lended-cons-position) - (etypecase location + (etypecase (operator location) ((eql :eax) (warn "lending EAX..") `((:movl :edi @@ -4123,7 +4126,7 @@ (:ebp ,(stack-frame-offset location))))))) (closure-binding ;; (warn "lend closure-binding: ~W => ~W" binding lended-cons-position) - (etypecase location + (etypecase (operator location) ((eql :argument-stack) `((:movl (:edi ,(global-constant-offset 'unbound-function)) :edx) (:movl :edi (:ebp ,(stack-frame-offset lended-cons-position))) ; cdr

1 0

← Newer
1
...
28
29
30
31
32
33
34
...
38
Older →

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 July 2004