Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv9077
Modified Files:
compiler.lisp
Log Message:
Started support for stack-allocating functions (of dynamic
extent). Primary purpose is to evaluate e.g. handler-case without
having to cons up a function for each handler.
Date: Mon Jan 3 12:55:05 2005
Author: ffjeld
Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.123 movitz/compiler.lisp:1.124
--- movitz/compiler.lisp:1.123 Tue Dec 21 15:23:49 2004
+++ movitz/compiler.lisp Mon Jan 3 12:55:04 2005
@@ -1,6 +1,6 @@
;;;;------------------------------------------------------------------
;;;;
-;;;; Copyright (C) 2001,2000, 2002-2004,
+;;;; Copyright (C) 2001,2000, 2002-2005,
;;;; Department of Computer Science, University of Tromso, Norway
;;;;
;;;; Description: A simple lisp compiler.
@@ -8,7 +8,7 @@
;;;; Created at: Wed Oct 25 12:30:49 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
-;;;; $Id: compiler.lisp,v 1.123 2004/12/21 14:23:49 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.124 2005/01/03 11:55:04 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -96,7 +96,7 @@
(make-hash-table :test #'eq))
-(defconstant +enter-stack-frame-code+
+(defparameter +enter-stack-frame-code+
'((:pushl :ebp)
(:movl :esp :ebp)
(:pushl :esi)))
@@ -189,6 +189,13 @@
(funobj-env
:initarg :funobj-env
:accessor funobj-env)
+ (extent
+ :initarg :extent
+ :initform :unused
+ :accessor movitz-funobj-extent)
+ (allocation
+ :initform nil
+ :accessor movitz-allocation)
(entry-protocol
:initform :default
:initarg :entry-protocol
@@ -643,18 +650,30 @@
(:call-lexical
(process-binding funobj (second instruction) '(:call)))
(:load-lambda
- (let ((lambda-binding (second instruction)))
+ (destructuring-bind (lambda-binding lambda-result-mode capture-env)
+ (cdr instruction)
+ (declare (ignore lambda-result-mode))
(assert (eq funobj (binding-funobj lambda-binding)) ()
"A non-local lambda doesn't make sense. There must be a bug.")
- (resolve-sub-funobj funobj (function-binding-funobj lambda-binding))
- (process-binding funobj lambda-binding '(:read))
- ;; This funobj is effectively using every binding that the lambda
- ;; is borrowing..
- (map nil (lambda (borrowed-binding)
- (process-binding funobj
- (borrowed-binding-target borrowed-binding)
- '(:read)))
- (borrowed-bindings (function-binding-funobj lambda-binding)))))
+ (let ((lambda-funobj (function-binding-funobj lambda-binding)))
+ (let ((dynamic-extent (dynamic-extent-allocation capture-env)))
+ (when dynamic-extent
+ (let ((dynamic-scope (allocation-env-scope dynamic-extent)))
+ ;; (warn "Adding ~S to ~S/~S" lambda-funobj dynamic-extent dynamic-scope)
+ (setf (movitz-funobj-extent lambda-funobj) :dynamic-extent
+ (movitz-allocation lambda-funobj) dynamic-scope)
+ (push lambda-funobj
+ (dynamic-extent-scope-members (allocation-env-scope dynamic-extent)))
+ (process-binding funobj (base-binding dynamic-scope) '(:read)))))
+ (resolve-sub-funobj funobj lambda-funobj)
+ (process-binding funobj lambda-binding '(:read))
+ ;; This funobj is effectively using every binding that the lambda
+ ;; is borrowing..
+ (map nil (lambda (borrowed-binding)
+ (process-binding funobj
+ (borrowed-binding-target borrowed-binding)
+ '(:read)))
+ (borrowed-bindings (function-binding-funobj lambda-binding))))))
(:local-function-init
(let ((function-binding (second instruction)))
(assert (eq funobj (binding-funobj function-binding)) ()
@@ -696,6 +715,7 @@
do (pushnew borrowed-binding
(getf (binding-lending (borrowed-binding-target borrowed-binding))
:lended-to)))
+ ;; (warn "old extent: ~S" (movitz-funobj-extent sub-funobj))
(cond
((or (null usage)
(null (borrowed-bindings sub-funobj)))
@@ -708,12 +728,16 @@
(change-class function-binding 'closure-binding)
(setf (movitz-funobj-extent sub-funobj)
:lexical-extent))
+ ((eq :dynamic-extent (movitz-funobj-extent sub-funobj))
+ (change-class function-binding 'closure-binding))
(t (change-class function-binding 'closure-binding)
(setf (movitz-funobj-extent sub-funobj)
:indefinite-extent))) ; XXX
- #+ignore (warn "extent: ~S => ~S"
- sub-funobj
- (movitz-funobj-extent sub-funobj)))))
+ #+ignore
+ (warn "extent usage ~S: ~S => ~S"
+ usage
+ sub-funobj
+ (movitz-funobj-extent sub-funobj)))))
(loop for function-binding in function-binding-usage by #'cddr
do (finalize-funobj (function-binding-funobj function-binding)))
(finalize-funobj toplevel-funobj))
@@ -1003,8 +1027,18 @@
(defun check-locate-concistency (code-vector)
(loop for x from 0 below (length code-vector) by 8
do (when (and (= (tag :basic-vector) (aref code-vector x))
- (= (enum-value 'movitz-vector-element-type :code) (aref code-vector (1+ x))))
- (break "Code-vector can break %find-code-vector at offset ~D." x)))
+ (= (enum-value 'movitz-vector-element-type :code) (aref code-vector (1+ x)))
+ (or (<= #x4000 (length code-vector))
+ (and (= (ldb (byte 8 0) (length code-vector))
+ (aref code-vector (+ x 2)))
+ (= (ldb (byte 8 8) (length code-vector))
+ (aref code-vector (+ x 3))))))
+ (break "Code-vector (length #x~X) can break %find-code-vector at ~D: #x~2,'0X~2,'0X ~2,'0X~2,'0X."
+ (length code-vector) x
+ (aref code-vector (+ x 0))
+ (aref code-vector (+ x 1))
+ (aref code-vector (+ x 2))
+ (aref code-vector (+ x 3)))))
(values))
#+ignore
@@ -1585,10 +1619,10 @@
(0 nil)
(1 (cadr c))
(2 (twop-dst c)))))
- (non-destructuve-p (c)
+ (non-destructive-p (c)
(let ((c (ignore-instruction-prefixes c)))
(and (consp c)
- (member (car c) '(:testl :testb :pushl :cmpl :cmpb :frame-map :std)))))
+ (member (car c) '(:testl :testb :cmpl :cmpb :frame-map :std)))))
(simple-instruction-p (c)
(let ((c (ignore-instruction-prefixes c)))
(and (listp c)
@@ -1627,7 +1661,7 @@
(or (global-funcall-p i)
(instruction-is i :frame-map)
(branch-instruction-label i)
- (non-destructuve-p i)
+ (non-destructive-p i)
(and (simple-instruction-p i)
(not (eql stack-location (stack-frame-operand (idst i)))))))))
(preserves-register-p (i register)
@@ -1637,10 +1671,12 @@
(not (eq register (idst i))))
(instruction-is i :frame-map)
(branch-instruction-label i)
- (non-destructuve-p i)
+ (non-destructive-p i)
(and (member register '(:edx))
(member (global-funcall-p i)
- '(fast-car fast-cdr fast-car-ebx fast-cdr-ebx)))))))
+ '(fast-car fast-cdr fast-car-ebx fast-cdr-ebx)))
+ (and (not (eq register :esp))
+ (instruction-is i :pushl))))))
(operand-register-indirect-p (operand register)
(and (consp operand)
(tree-search operand register)))
@@ -1811,7 +1847,7 @@
(twop-src ii))
(pushnew (store-stack-frame-p ii)
modifieds))
- ((non-destructuve-p ii))
+ ((non-destructive-p ii))
((branch-instruction-label ii))
((simple-instruction-p ii)
(let ((op (idst ii)))
@@ -2813,14 +2849,16 @@
(cdr (first init-pc))
(declare (ignore protect-registers protect-carry init-with-type))
(assert (eq binding init-binding))
- (let* ((load-instruction
- (find-if (lambda (i)
- (and (not (instruction-is i :init-lexvar))
- (member binding (find-read-bindings i)
- :test #'binding-eql)))
- (cdr init-pc)))
- (binding-destination (third load-instruction))
- (distance (position load-instruction (cdr init-pc))))
+ (multiple-value-bind (load-instruction binding-destination distance)
+ (loop for i in (cdr init-pc) as distance upfrom 0
+ do (when (not (instruction-is i :init-lexvar))
+ (multiple-value-bind (read-bindings read-destinations)
+ (find-read-bindings i)
+ (let ((pos (position binding read-bindings :test #'binding-eql)))
+ (when pos
+ (return (values i (nth pos read-destinations) distance)))))))
+ (declare (ignore load-instruction))
+ ;; (warn "load: ~S, dist: ~S, dest: ~S" load-instruction distance binding-destination)
(multiple-value-bind (free-registers more-later-p)
(and distance (compute-free-registers (cdr init-pc) distance funobj frame-map))
(let ((free-registers-no-ecx (remove :ecx free-registers)))
@@ -2912,6 +2950,15 @@
((:local-function-init :load-lambda)
(let ((function-binding (second instruction)))
(take-note-of-binding function-binding)
+ (let ((sub-funobj (function-binding-funobj function-binding)))
+ #+ignore
+ (warn "fun-ext: ~S ~S ~S"
+ sub-funobj
+ (movitz-funobj-extent sub-funobj)
+ (movitz-allocation sub-funobj))
+ (when (typep (movitz-allocation sub-funobj)
+ 'with-dynamic-extent-scope-env)
+ (take-note-of-binding (base-binding (movitz-allocation sub-funobj)))))
(let ((closure-funobj (function-binding-funobj function-binding)))
(dolist (borrowing-binding (borrowed-bindings closure-funobj))
(lend-lexical borrowing-binding nil)))))
@@ -3189,6 +3236,11 @@
(:load-lambda
(or (when load
(binding-eql binding (second instruction)))
+ (let ((allocation (movitz-allocation
+ (function-binding-funobj (second instruction)))))
+ (when (and load
+ (typep allocation 'with-dynamic-extent-scope-env))
+ (binding-eql binding (base-binding allocation))))
(search-funobj (function-binding-funobj (second instruction))
binding load store call)))
(:call-lexical
@@ -3321,9 +3373,6 @@
code)
env stack-frame-position frame-map))
-(defconstant +dynamic-frame-marker+ #xd193)
-(defconstant +dynamic-catch-marker+ #xd293)
-
(defun single-value-register (mode)
(ecase mode
((:eax :single-value :multiple-values :function) :eax)
@@ -3670,10 +3719,19 @@
(assert (eq funobj-register :edx))
(when (getf (binding-lending lended-binding) :dynamic-extent-p)
(assert dynamic-extent-p))
- ;; (warn "lending: ~W" lended-binding)
+ #+ignore
+ (warn "lending: ~W: ~S"
+ lended-binding
+ (mapcar #'movitz-funobj-extent
+ (mapcar #'binding-funobj
+ (getf (binding-lending lended-binding) :lended-to))))
(append (make-load-lexical lended-binding :eax funobj t frame-map)
(unless (or (typep lended-binding 'borrowed-binding)
- (getf (binding-lending lended-binding) :dynamic-extent-p))
+ (getf (binding-lending lended-binding) :dynamic-extent-p)
+ (every (lambda (borrower)
+ (member (movitz-funobj-extent (binding-funobj borrower))
+ '(:lexical-extent :dynamic-extent)))
+ (getf (binding-lending lended-binding) :lended-to)))
(append `((:pushl :edx)
(:globally (:call (:edi (:edi-offset ensure-heap-cons-variable))))
(:popl :edx))
@@ -3754,8 +3812,23 @@
nil)
((typep function-binding 'funobj-binding)
nil)
- (t (when (null (borrowed-bindings sub-funobj))
- (warn "null lending for ~S" sub-funobj))
+ #+ignore
+ ((member (movitz-funobj-extent sub-funobj)
+ '(:dynamic-extent :lexical-extent))
+ (check-type function-binding closure-binding)
+ (when (plusp (movitz-funobj-num-jumpers sub-funobj))
+ (break "Don't know yet how to stack a funobj with jumpers."))
+ (let ((words (+ (movitz-funobj-num-constants sub-funobj)
+ (/ (sizeof 'movitz-funobj) 4))))
+ (break "words for ~S: ~S" words sub-funobj)
+ (append `((:movl :esp :eax)
+ (:testl 4 :eax)
+ (:jz 'no-alignment-needed)
+ (:pushl :edi)
+ no-alignment-needed)
+ (make-load-constant sub-funobj :eax funobj frame-map)
+ )))
+ (t (assert (not (null (borrowed-bindings sub-funobj))))
(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)))
@@ -3765,8 +3838,9 @@
append (make-lend-lexical bb :edx nil))))))
funobj frame-map)))
(:load-lambda
- (destructuring-bind (function-binding register)
+ (destructuring-bind (function-binding register capture-env)
(operands instruction)
+ (declare (ignore capture-env))
;; (warn "load-lambda not completed for ~S" function-binding)
(finalize-code
(let* ((sub-funobj (function-binding-funobj function-binding))
@@ -3777,6 +3851,17 @@
((null lend-code)
;; (warn "null lambda lending")
(append (make-load-constant sub-funobj register funobj frame-map)))
+ ((typep (movitz-allocation sub-funobj)
+ 'with-dynamic-extent-scope-env)
+ (let ((dynamic-scope (movitz-allocation sub-funobj)))
+ (append (make-load-lexical (base-binding dynamic-scope) :edx
+ funobj nil frame-map)
+ `((:leal (:edx ,(tag :other)
+ ,(dynamic-extent-object-offset dynamic-scope
+ sub-funobj))
+ :edx))
+ lend-code
+ `((:movl :edx ,register)))))
(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)))
@@ -3921,7 +4006,7 @@
`((,op ,(new-make-compiled-constant-reference movitz-obj funobj)
,result-mode))))))))
-(defconstant +movitz-lambda-list-keywords+
+(defparameter +movitz-lambda-list-keywords+
'(muerte.cl:&OPTIONAL
muerte.cl:&REST
muerte.cl:&KEY
@@ -5825,16 +5910,18 @@
(assert (null unwind-protects) ()
"Lexical unwind-protect not implemented, to-env: ~S. (this is not supposed to happen)"
to-env)
+ ;; (warn "dist: ~S, slots: ~S" stack-distance num-dynamic-slots)
(cond
((and (eq t stack-distance)
- (zerop num-dynamic-slots))
+ (eql 0 num-dynamic-slots))
(compiler-values ()
:returns :non-local-exit
:code (append return-code
(unless (eq :function (exit-result-mode to-env))
- `((:load-lexical ,(save-esp-variable to-env) :esp)))
+ `((:load-lexical ,(movitz-binding (save-esp-variable to-env) to-env nil) :esp)))
`((:jmp ',to-label)))))
- ((eq t stack-distance)
+ ((or (eq t stack-distance)
+ (eq t num-dynamic-slots))
(compiler-values ()
:returns :non-local-exit
:code (append return-code
@@ -5850,7 +5937,7 @@
(:locally (:call (:edi (:edi-offset dynamic-unwind-next))))
(:locally (:movl :eax (:edi (:edi-offset dynamic-env))))
(:jc '(:sub-program () (:int 63))))))
- `((:load-lexical ,(save-esp-variable to-env) :esp)
+ `((:load-lexical ,(movitz-binding (save-esp-variable to-env) to-env nil) :esp)
(:jmp ',to-label)))))
((zerop num-dynamic-slots)
(compiler-values ()
@@ -5923,6 +6010,8 @@
(+ x y)
t))
(find-stack-delta (env stack-distance num-dynamic-slots unwind-protects)
+ #+ignore (warn "find-stack-delta: ~S dist ~S, slots ~S" env
+ (stack-used env) (num-dynamic-slots env))
(cond
((eq outer-env env)
;; Each dynamic-slot is 4 stack-distances, so let's check that..
@@ -5935,7 +6024,7 @@
(values nil 0 nil))
(t (find-stack-delta (movitz-environment-uplink env)
(stack-distance-add stack-distance (stack-used env))
- (+ num-dynamic-slots (num-dynamic-slots env))
+ (stack-distance-add num-dynamic-slots (num-dynamic-slots env))
(if (typep env 'unwind-protect-env)
(cons env unwind-protects)
unwind-protects))))))
@@ -6000,9 +6089,7 @@
(let* ((operator (car extended-instruction))
(finder (gethash operator *extended-code-find-read-binding*)))
(when finder
- (let ((result (funcall finder extended-instruction)))
- (check-type result list "a list of read bindings")
- result)))))
+ (funcall finder extended-instruction)))))
(defmacro define-find-write-binding-and-type (name lambda-list &body body)
(let ((defun-name (intern
@@ -6098,9 +6185,9 @@
(list source)))))
(define-find-read-bindings :load-lexical (source destination &key &allow-other-keys)
- (declare (ignore destination))
(check-type source binding)
- (list source))
+ (values (list source)
+ (list destination)))
(define-extended-code-expander :load-lexical (instruction funobj frame-map)
(destructuring-bind (source destination &key shared-reference-p tmp-register protect-registers)
@@ -6781,3 +6868,67 @@
(:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%2op)))
,eql-done))))
(t (error "unknown eql: ~S" instruction))))))))
+
+(define-find-read-bindings :load-lambda (lambda-binding result-mode capture-env)
+ (declare (ignore result-mode capture-env))
+ (let ((allocation (movitz-allocation (function-binding-funobj lambda-binding))))
+ (when (typep allocation 'with-dynamic-extent-scope-env)
+ (values (list (base-binding allocation))
+ (list :edx)))))
+
+(define-find-write-binding-and-type :enter-dynamic-scope (instruction)
+ (destructuring-bind (scope-env)
+ (cdr instruction)
+ (if (null (dynamic-extent-scope-members scope-env))
+ (values nil)
+ (values (base-binding scope-env) 'fixnum))))
+
+(define-extended-code-expander :enter-dynamic-scope (instruction funobj frame-map)
+ (declare (ignore funobj frame-map))
+ (destructuring-bind (scope-env)
+ (cdr instruction)
+ (if (null (dynamic-extent-scope-members scope-env))
+ nil
+ (append `((:pushl :edi)
+ (:movl :esp :eax)
+ (:andl 4 :eax)
+ (:addl :eax :esp))
+ (loop for object in (reverse (dynamic-extent-scope-members scope-env))
+ appending
+ (etypecase object
+ (movitz-funobj
+ (append (unless (zerop (mod (sizeof object) 8))
+ `((:pushl :edi)))
+ `((:load-constant ,object :eax))
+ (loop for i from (1- (movitz-funobj-num-constants object))
+ downto (movitz-funobj-num-jumpers object)
+ collect `(:pushl (:eax ,(slot-offset 'movitz-funobj 'constant0)
+ ,(* 4 i))))
+ (loop repeat (movitz-funobj-num-jumpers object)
+ do (error "Can't handle jumpers.")
+ collect `(:pushl 0))
+ `((:pushl (:eax ,(slot-offset 'movitz-funobj 'num-jumpers)))
+ (:pushl (:eax ,(slot-offset 'movitz-funobj 'name)))
+ (:pushl (:eax ,(slot-offset 'movitz-funobj 'lambda-list)))
+
+;;; (:pushl 0) ; %3op
+;;; (:pushl 0) ; %2op
+;;; (:pushl 0) ; %1op
+;;; (:pushl 0) ; (default)
+ (:pushl (:eax ,(slot-offset 'movitz-funobj 'code-vector%3op)))
+ (:pushl (:eax ,(slot-offset 'movitz-funobj 'code-vector%2op)))
+ (:pushl (:eax ,(slot-offset 'movitz-funobj 'code-vector%1op)))
+ (:pushl (:eax ,(slot-offset 'movitz-funobj 'code-vector)))
+
+ (:pushl (:eax ,(slot-offset 'movitz-funobj 'type))))))))))))
+
+;;;(define-extended-code-expander :exit-dynamic-scope (instruction funobj frame-map)
+;;; nil)
+
+(define-find-read-bindings :lexical-control-transfer (return-code return-mode from-env to-env
+ &optional to-label)
+ (declare (ignore return-code return-mode to-label))
+ (let ((distance (stack-delta from-env to-env)))
+ (when (eq t distance)
+ (values (list (movitz-binding (save-esp-variable to-env) to-env nil))
+ (list :esp)))))
