From ffjeld at common-lisp.net Thu Jul 21 17:28:47 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 21 Jul 2005 19:28:47 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20050721172847.2C7C188525@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv31166 Modified Files: compiler.lisp Log Message: For 1req1opt functions (i.e. with arglist like (x &optional y)), make the compiler not die in pain from certain situations. That is, we can now deal with e.g. (defun foo (x &optional y) (lambda () y)) which before we couldn't/wouldn't. Date: Thu Jul 21 19:28:46 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.147 movitz/compiler.lisp:1.148 --- movitz/compiler.lisp:1.147 Thu Jun 16 22:55:42 2005 +++ movitz/compiler.lisp Thu Jul 21 19:28:46 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.147 2005/06/16 20:55:42 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.148 2005/07/21 17:28:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -848,28 +848,35 @@ req-location opt-location))) (cond ((not optp-location) - ()) - ((= optp-location (1+ stack-setup-pre)) - (incf stack-setup-pre 1) - `((:pushl :edx))) + (make-stack-setup-code (- stack-frame-size stack-setup-pre))) + ((and (integerp optp-location) + (= optp-location (1+ stack-setup-pre))) + (append `((:pushl :edx)) + (make-stack-setup-code (- stack-frame-size stack-setup-pre 1)))) + ((integerp optp-location) + (append (make-stack-setup-code (- stack-frame-size stack-setup-pre)) + `((:movl :edx (:ebp ,(stack-frame-offset optp-location)))))) (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-lending 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.")) + (flet ((make-lending (location lended-cons-position) + (etypecase req-location + (integer + `((:movl (:ebp ,(stack-frame-offset 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 location)))))))) + (append + (when (binding-lended-p req-binding) + (make-lending req-location (getf (binding-lending req-binding) + :stack-cons-location))) + (when (binding-lended-p opt-binding) + (make-lending opt-location (getf (binding-lending opt-binding) + :stack-cons-location))) + (when (and optp-binding (binding-lended-p optp-binding)) + (make-lending optp-location (getf (binding-lending optp-binding) + :stack-cons-location))))) resolved-code (make-compiled-function-postlude funobj function-env use-stack-frame-p))))) From ffjeld at common-lisp.net Thu Jul 21 17:38:51 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 21 Jul 2005 19:38:51 +0200 (CEST) Subject: [movitz-cvs] CVS update: public_html/ChangeLog Message-ID: <20050721173851.2303888525@common-lisp.net> Update of /project/movitz/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv32083 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Thu Jul 21 19:38:50 2005 Author: ffjeld Index: public_html/ChangeLog diff -u public_html/ChangeLog:1.7 public_html/ChangeLog:1.8 --- public_html/ChangeLog:1.7 Tue Jun 14 01:00:56 2005 +++ public_html/ChangeLog Thu Jul 21 19:38:50 2005 @@ -1,3 +1,11 @@ +2005-07-21 Frode Vatvedt Fjeld + + * Fixed the compiler to handle e.g. + (defun foo (x &optional y) + (lambda () y)) + which before would cause the compiler to fail with a message about + not being able to lend optionals. + 2005-06-14 Frode Vatvedt Fjeld * Added dynamic growing and rehashing of hash-tables. From ffjeld at common-lisp.net Thu Jul 21 18:48:34 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 21 Jul 2005 20:48:34 +0200 (CEST) Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp Message-ID: <20050721184834.81DD988525@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv4535 Modified Files: storage-types.lisp Log Message: Add *hash-table-size-factor* variable. The size of the dumped hash-tables is now approximately computed as (* (hash-table-count hash-table) *hash-table-size-factor*) Date: Thu Jul 21 20:48:33 2005 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.54 movitz/storage-types.lisp:1.55 --- movitz/storage-types.lisp:1.54 Tue Jun 14 01:00:17 2005 +++ movitz/storage-types.lisp Thu Jul 21 20:48:33 2005 @@ -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.54 2005/06/13 23:00:17 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.55 2005/07/21 18:48:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1019,10 +1019,13 @@ (t (warn "Don't know how to take SXHASH of ~S." object) 0))) +(defvar *hash-table-size-factor* 5/4) + (defun make-movitz-hash-table (lisp-hash) (let* ((undef (movitz-read +undefined-hash-key+)) (hash-count (hash-table-count lisp-hash)) - (hash-size (logand -2 (truncate (* 2 4/3 (+ 7 hash-count))))) + (hash-size (logand -2 (truncate (* 2 (+ 7 hash-count) + *hash-table-size-factor*)))) (bucket-data (make-array hash-size :initial-element undef))) (multiple-value-bind (hash-test hash-sxhash) (ecase (hash-table-test lisp-hash) @@ -1058,7 +1061,8 @@ (let* ((undef (movitz-read +undefined-hash-key+)) (old-bucket (second (movitz-struct-slot-values movitz-hash))) (hash-count (hash-table-count lisp-hash)) - (hash-size (logand -2 (truncate (* 2 4/3 (+ 7 hash-count))))) + (hash-size (logand -2 (truncate (* 2 (+ 7 hash-count) + *hash-table-size-factor*)))) (bucket-data (or (and old-bucket (= (length (movitz-vector-symbolic-data old-bucket)) hash-size)