This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp".

The branch, tcall-convention has been created at 6bc8fe2052dbaa69ed9a5ce6c545f61e45ceb0a0 (commit)

- Log ----------------------------------------------------------------- commit 6bc8fe2052dbaa69ed9a5ce6c545f61e45ceb0a0 Merge: 8a35f22 eac8d34 Author: Raymond Toy toy.raymond@gmail.com Date: Sun Jun 24 09:46:32 2012 -0700

Merge branch 'tcall-convention' of https://github.com/ellerh/cmucl into tcall-convention

commit eac8d34cd595ff061f3cebae78ad8dab4d5f1cc4 Author: Helmut Eller eller.helmut@gmail.com Date: Sat Jun 23 19:41:24 2012 +0200

Remove TYPED-CALL-LOCAL vop.

The XEP no longer calls the unboxed entry point, so we don't this kind of local call anymore.

diff --git a/src/code/exports.lisp b/src/code/exports.lisp index 865b6e1..d58d113 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -1760,8 +1760,7 @@ "TN-REF-NEXT" "TN-REF-NEXT-REF" "TN-REF-P" "TN-REF-TARGET" "TN-REF-TN" "TN-REF-VOP" "TN-REF-WRITE-P" "TN-SC" "TN-VALUE" "TRACE-TABLE-ENTRY" "TYPE-CHECK-ERROR" - "TYPED-CALL-LOCAL" "TYPED-CALL-NAMED" - "TYPED-ENTRY-POINT-ALLOCATE-FRAME" + "TYPED-CALL-NAMED" "TYPED-ENTRY-POINT-ALLOCATE-FRAME" "UNBIND" "UNBIND-TO-HERE" "UNSAFE" "UNWIND" "UWP-ENTRY" "VALUE-CELL-REF" "VALUE-CELL-SET" "VALUES-LIST" diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index a255ddc..360f7c6 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -903,29 +903,6 @@ compilation policy") (move-continuation-result node block locs cont))))) (undefined-value))

-(defun ir2-convert-local-typed-call (node block fun cont) - (declare (type node node) (type ir2-block block) (type clambda fun) - (type continuation cont)) - (let ((ftype (the function-type (lambda-type fun))) - (args (basic-combination-args node)) - (start (getf (lambda-plist fun) :code-start))) - (multiple-value-bind (arg-tns result-tns - fp stack-frame-size - nfp number-stack-frame-size) - (make-typed-call-tns ftype) - (declare (ignore number-stack-frame-size)) - (collect ((actuals) (arg-locs)) - (loop for arg in args for loc in arg-tns do - (when arg - (actuals (continuation-tn node block arg)) - (arg-locs loc))) - (vop allocate-frame node block nil fp nfp) - (vop* typed-call-local node block - (fp nfp (reference-tn-list (actuals) nil)) - ((reference-tn-list result-tns t)) - (arg-locs) stack-frame-size start) - (move-continuation-result node block result-tns cont))))) - ;;; IR2-Convert-Local-Call -- Internal ;;; ;;; Dispatch to the appropriate function, depending on whether we have a @@ -953,13 +930,8 @@ compilation policy") (:unknown (ir2-convert-local-unknown-call node block fun cont start)) (:fixed - (ecase (getf (lambda-plist fun) :entry-point) - ((nil) - (ir2-convert-local-known-call node block fun returns - cont start)) - (:typed - (assert (external-entry-point-p (node-home-lambda node))) - (ir2-convert-local-typed-call node block fun cont))))))))) + (ir2-convert-local-known-call node block fun returns + cont start))))))) (undefined-value))

diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 63a8d07..7ebe917 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -761,37 +761,6 @@ (note-this-location vop :known-return) (trace-table-entry trace-table-normal)))

- -(define-vop (typed-call-local) - (:args (new-fp) - (new-nfp) - (args :more t)) - (:results (results :more t)) - (:save-p t) - (:move-args :local-call) - (:vop-var vop) - (:info arg-locs real-frame-size target) - (:ignore new-nfp args arg-locs results) - (:generator 30 - ;; FIXME: allocate the real frame size here. We had to emit - ;; ALLOCATE-FRAME before this vop so that we can use the - ;; (:move-args :local-call) option here. Without the - ;; ALLOCATE-FRAME vop we get a failed assertion. - (inst lea esp-tn (make-ea :dword :base new-fp - :disp (- (* real-frame-size word-bytes)))) - - ;; Write old frame pointer (epb) into new frame. - (storew ebp-tn new-fp (- (1+ ocfp-save-offset))) - - ;; Switch to new frame. - (move ebp-tn new-fp) - - (note-this-location vop :call-site) - - (inst call target) - - )) -  ;;; Return from known values call. We receive the return locations as ;;; arguments to terminate their lifetimes in the returning function. We

commit c0fccaf11debb5d8de1c805199a6c3dcdc8682a3 Author: Helmut Eller eller.helmut@gmail.com Date: Sat Jun 23 19:32:50 2012 +0200

New file with tests for the unboxed calling convention.

diff --git a/src/tests/unboxed-convention.lisp b/src/tests/unboxed-convention.lisp new file mode 100644 index 0000000..510968b --- /dev/null +++ b/src/tests/unboxed-convention.lisp @@ -0,0 +1,335 @@ +;; Tests for typed calling convention. + +(eval-when (:compile-toplevel) + (setq c::*check-consistency* t)) + +(in-package :cl-user) + +(defun fid (x) + (declare (double-float x) + (c::calling-convention :typed) + ) + x) + +(defun test-fid-1 () + (assert (= (fid 1d0) 1d0))) + +(defun f+ (x y) + (declare (double-float x y) + (c::calling-convention :typed)) + (+ x y)) + +(defun sum-prod (x y z u v w) + (declare (double-float x y z u v w) + (c::calling-convention :typed)) + (values (+ x y z u v w) + (* x y z u v w))) + +(defun test-sum-prod-1 () + (multiple-value-bind (sum prod) (sum-prod 2d0 3d0 4d0 5d0 6d0 7d0) + (assert (= sum (+ 2d0 3d0 4d0 5d0 6d0 7d0))) + (assert (= prod (* 2d0 3d0 4d0 5d0 6d0 7d0))))) + +(defun test-sum-prod-2 () + (multiple-value-bind (sum) (sum-prod 2d0 3d0 4d0 5d0 6d0 7d0) + (assert (= sum (+ 2d0 3d0 4d0 5d0 6d0 7d0))))) + +(defun test-sum-prod-3-aux (x y z u v w) + (sum-prod x y z u v w)) + +(defun test-sum-prod-3 () + (multiple-value-bind (sum prod) (test-sum-prod-3-aux 2d0 3d0 4d0 5d0 6d0 7d0) + (assert (= sum (+ 2d0 3d0 4d0 5d0 6d0 7d0))) + (assert (= prod (* 2d0 3d0 4d0 5d0 6d0 7d0))))) + +(defun id (x) + (declare (c::calling-convention :typed)) + x) + +(defun test-id-1 () + (assert (eql (id 1) 1))) + +(defun test-id-2 () + (assert (eql (id 1d0) 1d0))) + +(defun test-id-3 () + (assert (equal (multiple-value-list (id 1d0)) '(1d0)))) + +;; This one has both boxed and unboxed arguments. +(defun cons-sum (o1 f1 o2 f2) + (declare (double-float f1 f2) + (c::calling-convention :typed)) + (values (cons o1 o2) (+ f1 f2))) + +(defun test-cons-sum-1 () + (multiple-value-bind (cons sum) (cons-sum 1 2d0 3 4d0) + (assert (equal cons '(1 . 3))) + (assert (= sum (+ 2d0 4d0))))) + +(defun ffib (x) + (declare (double-float x) + (c::calling-convention :typed)) + (the double-float + (cond ((= x 0) 0d0) + ((= x 1) 1d0) + (t (+ (ffib (- x 1)) + (ffib (- x 2))))))) + +;; (time (ffib 30d0)) + +(defun test-ffib-1 () + (assert (= (ffib 0d0) 0)) + (assert (= (ffib 1d0) 1)) + (assert (= (ffib 2d0) 1)) + (assert (= (ffib 3d0) 2)) + (assert (= (ffib 4d0) 3)) + (assert (= (ffib 5d0) 5)) + (assert (= (ffib 6d0) 8)) + (assert (= (ffib 7d0) 13)) + (assert (= (ffib 8d0) 21))) + +;; (test-ffib-1) + + +;; SUM will be redefined with different types to exercise the linker a +;; bit. +(defun sum (f1 f2) + (declare (double-float f1 f2) + (c::calling-convention :typed)) + (+ f1 f2)) + +(defun test-sum-1 () + (assert (= (sum 2d0 3d0) 5d0))) + +(defun sum (f1 f2) + (declare (c::calling-convention :typed)) + (+ f1 f2)) + +(defun test-sum-2 () + (assert (= (sum 2d0 3d0) 5d0))) + +(defun test-sum-3 () + (handler-case (progn (sum 2 3) + (assert nil)) + (type-error (c) + (assert (equal (type-error-datum c) 3)) + (assert (eq (type-error-expected-type c) 'double-float))))) + +(defun sum (f1 f2) + (declare (double-float f2) + (c::calling-convention :typed)) + (the double-float + (+ f1 f2))) + +(defun test-sum-4 () + (assert (= (sum 2d0 3d0) 5d0))) + +(defun test-sum-5 () + (assert (= (sum 2 3d0) 5d0))) + +(defun test-sum-6 () + (handler-case (progn + (sum #c(0 1) 3d0) + (assert nil)) + (type-error (c) + (assert (equal (type-error-datum c) #c(3d0 1d0))) + (assert (eq (type-error-expected-type c) 'double-float))))) + +(defun sum (f1 f2) + (declare (double-float f2)) + (the double-float + (+ f1 f2))) + +(defun test-sum-7 () + (assert (= (sum 2 3d0) 5d0))) + +;; (ext:info function kernel::linkage 'sum) + +(defun wild (f x y) + (declare (type function f) + (double-float x y) + (c::calling-convention :typed)) + (funcall f x y)) + +(defun test-wild-1 () + (assert (= (wild #'+ 3d0 5d0) 8d0))) + +(defun test-wild-2 () + (assert (equal (multiple-value-list (wild #'values 3d0 5d0)) + '(3d0 5d0)))) + + +(defun opt-result (x y) + (declare (double-float x y) + (c::calling-convention :typed)) + (if (zerop x) + y + (values x y))) + +(defun test-opt-result-1 () + (assert (= (opt-result 0d0 3d0) 3d0))) + +(defun test-opt-result-2 () + (assert (= (opt-result 1d0 3d0) 1d0))) + +(defun test-opt-result-3 () + (assert (equal (multiple-value-list (opt-result 1d0 3d0)) + '(1d0 3d0)))) + +(defun test-opt-result-3 () + (assert (equal (multiple-value-list (opt-result 0d0 3d0)) + '(3d0)))) + +;;(defun opt-arg (x &optional (y 0d0)) +;; (declare (double-float x y) +;; (c::calling-convention :typed)) +;; (+ x y)) + +(declaim (inline inlined-fun)) +(defun inlined-fun (obj) + (declare (c::calling-convention :typed)) + obj) + +(defun test-inlined-fun-1 () + (assert (eq (inlined-fun 'x) 'x))) + +(defun unused-arg-fun (x) + (declare (ignore x)) + (declare (c::calling-convention :typed)) + nil) + +(defun test-unused-arg-fun-1 () + (assert (eq (unused-arg-fun 'x) nil))) + +(let ((state 0)) + (defun closure () + (declare (c::calling-convention :typed)) + (mod (incf state) 2))) + +(defun test-closure-1 () + (assert (member (closure) '(0 1))) + (assert (member (closure) '(0 1)))) + +(defun self-ref () + (declare (c::calling-convention :typed)) + #'self-ref) + +(defun test-self-ref-1 () + (assert (eq #'self-ref (funcall (self-ref))))) + +(defun many-args (a b c d e f g h i j k l m n o p) + (declare (c::calling-convention :typed)) + (list a b c d e f g h i j k l m n o p)) + +(defun test-many-args-1 () + (assert (equal (many-args 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k 'l 'm 'n 'o 'p) + '(a b c d e f g h i j k l m n o p)))) + +;; (compile-file "/tmp/x.lisp" :trace-file "/tmp/x.trace" :progress t) + + +(defun many-results (a b c d e f g h i j k l m n o p) + (declare (c::calling-convention :typed)) + (values m n o p a b c d e f g h i j k l)) + +(defun test-many-results-1 () + (assert (equal (multiple-value-list + (many-results + 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k 'l 'm 'n 'o 'p)) + '(m n o p a b c d e f g h i j k l)))) + +#+(or) +(defun pcl::pcl-funcallable-instance-slots (object) + (declare ;;(type pcl::pcl-funcallable-instance object) + (c::calling-convention :typed)) + (kernel:%funcallable-instance-info object 0)) + +;; (c::clear-info function c::calling-convention 'pcl::pcl-funcallable-instance-slots) + +;; (c::info function calling-convention 'pcl::pcl-funcallable-instance-slots) + +(defun 6args (a b c d e f g) + (declare (c::calling-convention :typed)) + (list a b c d e f g)) + +(defun set-arg () + (let (a) + (setq a nil) + (6args nil nil nil a a a nil))) + +(defun 2values () + (declare (c::calling-convention :typed)) + (values 1 2)) + +(defun call-1-or-2-values (x) + (declare (c::calling-convention :typed)) + (or x + (2values))) + + +(defun test-call-1-or-2-values-1 () + (assert (equal (multiple-value-list (call-1-or-2-values 1)) + '(1)))) + +(defun test-call-1-or-2-values-2 () + (assert (equal (multiple-value-list (call-1-or-2-values nil)) + '(1 2)))) + +(defun deleted-fun (x) + (labels ((d () + (declare (c::calling-convention :typed)))) + #'d + x)) + +(defun gf-fun (x) + (declare (c::calling-convention :typed)) + x) + +;;(defun call-gf-fun (x) +;; (gf-fun x)) +;; +;;(defgeneric gf-fun (x)) +;;(defmethod gf-fun (x) +;; x) + + +#+(or) +(defun foo () + (labels ((sum (x y) (+ x y))) + (declare (ftype (function (double-float double-float) double-float) sum)) + (list (sum 2d0 4d0) + (sum 2 4)))) + +(defun tests () + (test-fid-1) + (test-sum-prod-1) + (test-sum-prod-2) + (test-sum-prod-3) + (test-id-1) + (test-id-2) + (test-id-3) + (test-cons-sum-1) + (test-ffib-1) + (test-sum-1) + (test-sum-2) + (test-sum-3) + (test-sum-4) + (test-sum-5) + (test-sum-6) + (test-sum-7) + (test-wild-1) + (test-wild-2) + (test-opt-result-1) + (test-opt-result-2) + (test-opt-result-3) + (test-inlined-fun-1) + (test-unused-arg-fun-1) + (test-closure-1) + (test-self-ref-1) + (test-many-args-1) + (test-many-results-1) + (test-call-1-or-2-values-1) + (test-call-1-or-2-values-2) + ) + +;; (tests)

commit b7023422cee56e3f90d88a6c961bc7160879401c Author: Helmut Eller eller.helmut@gmail.com Date: Sat Jun 23 19:20:15 2012 +0200

Be more careful when creating adapters.

* code/fdefinition.lisp (generate-adapter-function): Simply use :typed convention instead of the :typed-no-xep. I removed :typed-no-xep as it was probably a premature optimisation. Also switch directly to full-call convention instead of trying to stay with typed convention. (check-function-redefinition): Handle the case when the new function doesn't have a typed entry point.

diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index 61725e6..e36e214 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -398,13 +398,14 @@ nil `(lambda ,tmps (declare - (c::calling-convention :typed-no-xep) + (c::calling-convention :typed) ,@(loop for tmp in tmps for type in atypes collect `(type ,(kernel:type-specifier type) ,tmp))) (the ,(kernel:type-specifier (kernel:function-type-returns ftype)) - (funcall (function ,name) . ,tmps)))))) + (funcall ',name . ,tmps))))) + (fun (find-typed-entry-point-for-function fun nil))) (validate-adapter-type fun ftype) fun))

@@ -475,7 +476,8 @@ (dolist (cs (listify (linkage-callsites linkage))) (let ((cs-type (callsite-type cs)) (fdefn (callsite-fdefn cs))) - (cond ((function-types-compatible-p cs-type new-type) + (cond ((and new-tep + (function-types-compatible-p cs-type new-type)) (patch-fdefn fdefn new-tep)) ((dolist (fun (listify (linkage-adapters linkage))) (let ((ep-type (kernel:extract-function-type fun)))

commit 129c095c35fb5233c48795b5defe85d5c3427b81 Author: Helmut Eller eller.helmut@gmail.com Date: Sat Jun 23 19:14:59 2012 +0200

For typed-call-named force new-fp into register.

We use the lea instruction so new-fp needs to be in a register.

diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 6a0b59f..63a8d07 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -1150,7 +1150,7 @@

(define-vop (typed-call-named) - (:args (new-fp) + (:args (new-fp :scs (any-reg) :to (:argument 1)) (new-nfp) (fdefn :scs (descriptor-reg control-stack) :target eax)

commit 972472c0ccc627d7003b72105a50d505626812d1 Author: Helmut Eller eller.helmut@gmail.com Date: Sat Jun 23 19:12:45 2012 +0200

Lift restriction on number of return values.

Apparently we can return values on the stack just fine. Don't allow ftypes with function-type-wild-args.

diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index d7dd473..6a0b59f 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -228,17 +228,14 @@ (arg-tn (type state) (cond ((double-float-type-p type) (double-float-arg state)) (t (boxed-arg state)))) - (ret-tn (type state) - (let ((tn (arg-tn type state))) - (assert (member (sc-name (tn-sc tn)) - '(double-reg descriptor-reg))) - tn))) + (ret-tn (type state) (arg-tn type state))) (let* ((arg-state (list :frame-size 2 :xmms-reg xmm4-offset :reg-args 0)) (ret-state (list :frame-size 2 :xmms-reg xmm4-offset :reg-args 0))) (values (multiple-value-bind (min max) (function-type-nargs ftype) (assert (and min max (= min max)) () "Only fixed number of arguments supported (currently)") + (assert (not (function-type-wild-args ftype))) (loop for type in (function-type-required ftype) collect (arg-tn type arg-state))) (multiple-value-bind (types count)

commit 7fdc7377e601a50e3f8085417881b99667c8ac6a Author: Helmut Eller eller.helmut@gmail.com Date: Sat Jun 23 19:10:41 2012 +0200

Fix off-by-one error when choosing argument registers.

* compiler/x86/call.lisp (make-typed-call-tns): Use < not <= when comparing with register-arg-count.

diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index cad0b46..d7dd473 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -212,7 +212,7 @@ (prog1 (getf state :frame-size) (incf (getf state :frame-size) 2)))))) (boxed-arg (state) - (cond ((<= (getf state :reg-args) register-arg-count) + (cond ((< (getf state :reg-args) register-arg-count) (let ((n (getf state :reg-args))) (incf (getf state :reg-args)) (x86-standard-argument-location n)))

commit ecd220e44f71fa92c571adce2da2a0ffcd2fc6d1 Author: Helmut Eller eller.helmut@gmail.com Date: Sat Jun 23 19:10:02 2012 +0200

Handle multiple-value-call with fixed numer of values.

* compiler/ir2tran.lisp (%typed-call-ir2-convert-optimizer): Don't use multiple-value-call-named if the the callee returns a fixed number of values. typed-call-named + move-continuation-result seems to handle the multiple-value-call case just fine.

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 363d6f7..a255ddc 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -1801,8 +1801,8 @@ compilation policy") collect (continuation-tn node block arg))) (arg-refs (reference-tn-list cont-tns nil))) (vop allocate-frame node block nil fp nfp) - (cond ((and 2cont (eq (ir2-continuation-kind 2cont) :unknown)) - (assert (eq result-tns :unknown)) + (cond ((and 2cont (eq (ir2-continuation-kind 2cont) :unknown) + (eq result-tns :unknown)) (vop* x86::multiple-typed-call-named node block (fp nfp fdefn-tn arg-refs) ((reference-tn-list (ir2-continuation-locs 2cont) t))

commit affcb90ee0d7094ec830181ce8a0cca2863e8d40 Author: Helmut Eller eller.helmut@gmail.com Date: Sat Jun 23 19:06:38 2012 +0200

Don't use typed calling convention with wild-args-type.

This shouldn't happen normally, but it did happen when I enabled the typed calling convention for all defuns.

* compiler/ir1opt.lisp (recognize-known-call): Look at the ftype more closesly. Also ignore known functions.

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 9cb17ab..f00f400 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -953,9 +953,16 @@ (info (ecase cc ((nil) info) ((:typed :typed-no-xep) - (cond ((not info) + (cond ((and (not info) + (let ((ftype (continuation-derived-type + (combination-fun call)))) + (and (function-type-p ftype) + (not (function-type-wild-args + ftype))))) (info function info '%typed-call)) - (t (error "nyi"))))))) + (t + ;;(error "nyi") + info)))))) (if info (values leaf (setf (basic-combination-kind call) info)) (values leaf nil)))))))

commit 3a9616c76b41ec0287cff3ce23a4860cec28f4b3 Author: Helmut Eller eller.helmut@gmail.com Date: Sat Jun 23 19:02:27 2012 +0200

Stop freaking out if *check-consistency* is T.

Make the checks aware of the typed entry point.

diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index 18bf155..900559a 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -235,7 +235,8 @@ (check-function-reached ef functional) (unless (or (member functional (optional-dispatch-entry-points ef)) (eq functional (optional-dispatch-more-entry ef)) - (eq functional (optional-dispatch-main-entry ef))) + (eq functional (optional-dispatch-main-entry ef)) + (eq functional (optional-dispatch-typed-entry ef))) (barf ":Optional ~S not an e-p for its OPTIONAL-DISPATCH ~S." functional ef)))) (:top-level @@ -927,7 +928,8 @@ (unless (or (eq (global-conflicts-kind conf) :write) (eq tn pc) (eq tn fp) - (and (external-entry-point-p fun) + (and (or (external-entry-point-p fun) + (typed-entry-point-p fun)) (tn-offset tn)) (member (tn-kind tn) '(:environment :debug-environment)) (member tn vars :key #'leaf-info)

commit 636d521a629a8da3442a0b788365596fa67ef6bb Author: Helmut Eller eller.helmut@gmail.com Date: Sat Jun 23 18:53:56 2012 +0200

No longer wire arg TNs of typed entry.

The XEP no longer calls the typed entry so we don't need wired locations.

* compiler/gtn.lisp (assign-typed-lambda-var-tns): Deleted. (assign-normal-lambda-var-tns): Renamed back to assign-lambda-var-tns. (typed-entry-point-type): Take the ftype from the optional-dispatch or the main entry

* compiler/ir2tran.lisp (init-typed-entry-point-environment): Now move args from wired locations to locations chosen by GTN. This seems to cause fewer problem during packing.

diff --git a/src/compiler/gtn.lisp b/src/compiler/gtn.lisp index 1cc15bf..bce94a5 100644 --- a/src/compiler/gtn.lisp +++ b/src/compiler/gtn.lisp @@ -50,14 +50,6 @@ ;;; (defun assign-lambda-var-tns (fun let-p) (declare (type clambda fun)) - (cond ((typed-entry-point-p fun) - (assign-typed-lambda-var-tns fun)) - (t - (assign-normal-lambda-var-tns fun let-p))) - (undefined-value)) - -(defun assign-normal-lambda-var-tns (fun let-p) - (declare (type clambda fun)) (dolist (var (lambda-vars fun)) (when (leaf-refs var) (let* ((type (if (lambda-var-indirect var) @@ -72,16 +64,8 @@ (environment-debug-live-tn temp (lambda-environment fun))))) (setf (tn-leaf res) var) - (setf (leaf-info var) res))))) - -(defun assign-typed-lambda-var-tns (fun) - (declare (type clambda fun)) - (let ((ftype (typed-entry-point-type fun))) - (loop for var in (lambda-vars fun) - for tn in (make-typed-call-tns ftype) - do (when (leaf-refs var) - (setf (tn-leaf tn) var) - (setf (leaf-info var) tn))))) + (setf (leaf-info var) res)))) + (undefined-value))

;;; Assign-IR2-Environment -- Internal ;;; @@ -233,8 +217,12 @@ :locations (mapcar #'make-normal-tn ptypes))))))

(defun typed-entry-point-type (fun) - (declare (type clambda fun)) - (lambda-type (lambda-entry-function fun))) + (declare (type clambda fun) (values function-type)) + (let* ((opt (lambda-optional-dispatch fun)) + (type1 (optional-dispatch-type opt))) + (typecase type1 + (function-type type1) + (t (lambda-type (optional-dispatch-main-entry opt))))))

(defun return-info-for-typed-entry-point (fun) (declare (type clambda fun)) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index a796d1a..363d6f7 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -1205,16 +1205,21 @@ compilation policy")

(undefined-value))

-;; arguments are wired to specific locations in gtn so we should have -;; to move them here. (defun init-typed-entry-point-environment (node block fun) (declare (type bind node) (type ir2-block block) (type clambda fun)) - (let ((start-label (entry-info-offset (leaf-info fun))) - (code-label (getf (lambda-plist fun) :code-start)) - (env (environment-info (node-environment node)))) + (let* ((start-label (entry-info-offset (leaf-info fun))) + (code-label (getf (lambda-plist fun) :code-start)) + (env (environment-info (node-environment node))) + (ftype (typed-entry-point-type fun)) + (arg-tns (make-typed-call-tns ftype))) (vop typed-entry-point-allocate-frame node block start-label code-label) (vop setup-environment node block start-label) + (loop for var in (lambda-vars fun) + for pass in arg-tns do + (when (leaf-refs var) + (let ((home (leaf-info var))) + (emit-move node block pass home)))) (emit-move node block (make-old-fp-passing-location t) (ir2-environment-old-fp env))))

commit 1ce39124cc2076b5eb64ee0a77979ba14253ca74 Author: Helmut Eller eller.helmut@gmail.com Date: Sat Jun 23 18:51:24 2012 +0200

Take the type for the fasl file from the optional-dispatch.

diff --git a/src/compiler/entry.lisp b/src/compiler/entry.lisp index 48f5c96..902f472 100644 --- a/src/compiler/entry.lisp +++ b/src/compiler/entry.lisp @@ -109,11 +109,9 @@ (defun compute-entry-info (fun info) (declare (type clambda fun) (type entry-info info)) (let* ((bind (lambda-bind fun)) - (internal-fun (functional-entry-function fun)) - (internal-fun (cond ((typed-entry-point-p internal-fun) - (functional-entry-function internal-fun)) - (t internal-fun))) - (tep (typed-entry-point-p fun))) + (tep (typed-entry-point-p fun)) + (internal-fun (cond (tep (lambda-optional-dispatch fun)) + (t (functional-entry-function fun))))) (setf (entry-info-closure-p info) (not (null (environment-closure (lambda-environment fun))))) (setf (entry-info-offset info) (gen-label)) @@ -151,9 +149,6 @@ (case (functional-kind lambda) (:external (let* ((ef (functional-entry-function lambda)) - (ef (cond ((typed-entry-point-p ef) - (functional-entry-function ef)) - (t ef))) (new (make-functional :kind :top-level-xep :info (leaf-info lambda) :name (leaf-name ef)

commit dfc1d8a813c922c3c6651af19bf81b7faf4c1dc8 Author: Helmut Eller eller.helmut@gmail.com Date: Sat Jun 23 18:45:36 2012 +0200

Don't delete the typed entry point as long as a XEP is there.

* compiler/envanal.lisp (environment-analyze): Don't delete the typed entry point even if it has no references.

* compiler/ir1util.lisp (delete-optional-dispatch): But here delete the typed entry too.

diff --git a/src/compiler/envanal.lisp b/src/compiler/envanal.lisp index 4ca29ee..8f96339 100644 --- a/src/compiler/envanal.lisp +++ b/src/compiler/envanal.lisp @@ -57,7 +57,8 @@ (when (null (leaf-refs fun)) (let ((kind (functional-kind fun))) (unless (or (eq kind :top-level) - (and *byte-compiling* (eq kind :optional))) + (and *byte-compiling* (eq kind :optional)) + (typed-entry-point-p fun)) (assert (member kind '(:optional :cleanup :escape))) (setf (functional-kind fun) nil) (delete-functional fun))))) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 1082202..bf77e71 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -916,6 +916,8 @@ (frob ep)) (when (optional-dispatch-more-entry leaf) (frob (optional-dispatch-more-entry leaf))) + (when (optional-dispatch-typed-entry leaf) + (frob (optional-dispatch-typed-entry leaf))) (let ((main (optional-dispatch-main-entry leaf))) (when (eq (functional-kind main) :optional) (frob main))))))

commit b4ffef7812b7f1bb378d220fc1e75d0588077c2e Author: Helmut Eller eller.helmut@gmail.com Date: Sat Jun 23 18:42:08 2012 +0200

Make typed entry point part of optional-dispatch.

Previously the typed entry point was a lambda with a marker in the lambda-plist. Now the typed entry point is part of a optional-dispatch struct. The previous approach kinda worked for simple cases, but it was getting awkward when references to the XEP had to be back-patched. The new approach seems to work better; it's nice that both the main entry and the XEP can be reached from the optional-dispatch.

* compiler/node.lisp (optional-dispatch): Add new slots. The typedp slot is set during ir1trans and the actual entry point is generated at the same time as the XEP. Doing it a little later lets the types settle a bit better.

* compiler/ir1tran.lisp (ir1-convert-lambda): Create a hairy lambda when for the typed calling convention. (ir1-convert-hairy-args): Add new argument typedp and pass it to constructor.

* compiler/locall.lisp (generate-typed-entry): New function (make-xep-lambda): Remove the code for the old strategy. (make-external-entry-point): Generate the typed entry point if typed is true.

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index e55b334..ae0c887 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1586,10 +1586,11 @@ (calling-convention (find-declaration 'calling-convention decls 1 0)) (entry-point (find-declaration 'entry-point decls 1 0)) - (res (if (or (find-if #'lambda-var-arg-info vars) keyp) + (typed (eq calling-convention :typed)) + (res (if (or (find-if #'lambda-var-arg-info vars) keyp typed) (ir1-convert-hairy-lambda new-body vars keyp allow-other-keys - aux-vars aux-vals cont) + aux-vars aux-vals cont typed) (ir1-convert-lambda-body new-body vars aux-vars aux-vals t cont)))) (setf (functional-inline-expansion res) form) @@ -1607,7 +1608,7 @@ (eq 'declare (first decl)) (cons 'pcl::method (cadadr decl)))))) (when calling-convention - (setf (getf (lambda-plist res) :calling-convention) + (setf (getf (functional-plist res) :calling-convention) calling-convention)) (when entry-point (setf (getf (lambda-plist res) :entry-point) entry-point)) @@ -1970,7 +1971,7 @@ (cons arg entry-vars) (list* t arg-name entry-vals) (rest vars) t body aux-vars aux-vals cont) - (ir1-convert-hairy-args + (ir1-convert-hairy-args res (cons arg default-vars) (cons arg-name default-vals) @@ -2303,18 +2304,18 @@ nil nil nil vars supplied-p-p body aux-vars aux-vals cont)))))))

- ;;; IR1-Convert-Hairy-Lambda -- Internal ;;; ;;; This function deals with the case where we have to make an ;;; Optional-Dispatch to represent a lambda. We cons up the result and call ;;; IR1-Convert-Hairy-Args to do the work. When it is done, we figure out the -;;; min-args and max-args. +;;; min-args and max-args. ;;; -(defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals cont) +(defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals cont + typedp) (declare (list body vars aux-vars aux-vals) (type continuation cont)) (let ((res (make-optional-dispatch :arglist vars :allowp allowp - :keyp keyp)) + :keyp keyp :typedp typedp)) (min (or (position-if #'lambda-var-arg-info vars) (length vars)))) (push res (component-new-functions *current-component*)) (ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals @@ -2331,10 +2332,9 @@ (dolist (ep (optional-dispatch-entry-points res)) (frob ep)) (frob (optional-dispatch-more-entry res)) (frob (optional-dispatch-main-entry res))) - + res))

-

(declaim (end-block))  diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index d2582fb..2d3529f 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -145,38 +145,7 @@ (clambda (let* ((nargs (length (lambda-vars fun))) (n-supplied (gensym)) - (temps (loop repeat nargs collect (gensym))) - (fun (ecase (getf (lambda-plist fun) :calling-convention) - ((nil) fun) - (:typed - (let ((fun2 (ir1-convert-lambda - `(lambda ,temps - (declare (entry-point :typed)) - ,@(loop for tmp in temps - for var in (lambda-vars fun) - collect - `(declare (type - ,(type-specifier - (lambda-var-type var)) - ,tmp))) - (%funcall ,fun . ,temps))))) - (setf (lambda-entry-function fun) fun2) - fun2)) - (:typed-no-xep - (return-from make-xep-lambda - `(lambda ,temps - (declare (entry-point :typed) - ,@(loop for tmp in temps - for var in (lambda-vars fun) - collect - `(type ,(type-specifier - (lambda-var-type var)) - ,tmp))) - (the ,(type-specifier - (continuation-asserted-type - (return-result - (lambda-return fun)))) - (%funcall ,fun . ,temps)))))))) + (temps (loop repeat nargs collect (gensym)))) `(lambda (,n-supplied . ,temps) (declare (type index ,n-supplied)) ,(if (policy nil (zerop safety)) @@ -215,6 +184,26 @@ (%argument-count-error ,n-supplied)))))))))

+(defun generate-typed-entry (fun) + (declare (type optional-dispatch fun)) + (let* ((main (optional-dispatch-main-entry fun)) + (temps (loop for nil in (lambda-vars main) + collect (gensym))) + (tep (ir1-convert-lambda + `(lambda ,temps + (declare (entry-point :typed)) + ,@(loop for tmp in temps for var in (lambda-vars main) + collect `(declare + (type + ,(type-specifier (lambda-var-type var)) + ,tmp))) + (%funcall ,main . ,temps))))) + (setf (optional-dispatch-typed-entry fun) tep) + (setf (functional-kind tep) :optional) + (setf (leaf-ever-used tep) t) + (setf (lambda-optional-dispatch tep) fun))) + + ;;; Make-External-Entry-Point -- Internal ;;; ;;; Make an external entry point (XEP) for Fun and return it. We convert @@ -237,21 +226,19 @@ (res (ir1-convert-lambda (make-xep-lambda fun)))) (setf (functional-kind res) :external) (setf (leaf-ever-used res) t) - (cond ((functional-entry-function fun) - (let ((ep (functional-entry-function fun))) - (setf (functional-entry-function ep) fun) - (setf (functional-entry-function fun) ep) - (setf (functional-entry-function res) ep))) - (t - (setf (functional-entry-function res) fun) - (setf (functional-entry-function fun) res))) + (setf (functional-entry-function res) fun) + (setf (functional-entry-function fun) res) (setf (component-reanalyze *current-component*) t) (setf (component-reoptimize *current-component*) t) (etypecase fun (clambda (local-call-analyze-1 fun)) (optional-dispatch + (when (optional-dispatch-typedp fun) + (generate-typed-entry fun)) (dolist (ep (optional-dispatch-entry-points fun)) (local-call-analyze-1 ep)) + (when (optional-dispatch-typed-entry fun) + (local-call-analyze-1 (optional-dispatch-typed-entry fun))) (when (optional-dispatch-more-entry fun) (local-call-analyze-1 (optional-dispatch-more-entry fun))))) res))) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 851d9bf..ece4061 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -1037,7 +1037,11 @@ ;; including keywords as fixed arguments. The format of the arguments must ;; be determined by examining the arglist. This may be used by callers that ;; supply at least Max-Args arguments and know what they are doing. - (main-entry nil :type (or clambda null))) + (main-entry nil :type (or clambda null)) + ;; + ;; True if a typed entry point should be generated. + (typedp nil :type boolean :read-only t) + (typed-entry nil :type (or clambda null)))

(defprinter optional-dispatch

commit 8a35f2256800afd1f0962c33fed7f64303e6c3be Merge: 8a9d1d8 6b3aba6 Author: Raymond Toy toy.raymond@gmail.com Date: Sat Jun 23 08:24:44 2012 -0700

Merge branch 'tcall-convention' of https://github.com/ellerh/cmucl into eller-typed-call

commit b974e915a0399bb432cc21cd4d1723a1423e00bd Author: Helmut Eller eller.helmut@gmail.com Date: Fri Jun 22 12:30:47 2012 +0200

Don't need fop-fset for typed entry points.

diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index c3b2ed0..f7badbe 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -660,7 +660,9 @@ ;; flet/labels functions. We don't ;; need them stored because we can't ;; really do anything with them. - (not (member (car name) '(flet labels) :test 'eq) )))) + (not (member (car name) + '(flet labels :typed-entry-point) + :test 'eq) )))) (dump-object name file) (dump-push handle file) (dump-fop 'lisp::fop-fset file))

commit e48ee801750f31adb490bb8118a67bd3f37bf85b Author: Helmut Eller eller.helmut@gmail.com Date: Fri Jun 22 12:29:18 2012 +0200

Disable local inline expansion into typed entry points.

* compiler/locall.lisp (maybe-expand-local-inline): Treat typed entry points like external entry points.

diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index d2e8d3e..d2582fb 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -362,7 +362,9 @@ ;;; (defun maybe-expand-local-inline (fun ref call) (if (and (policy call (>= speed space) (>= speed cspeed)) - (not (eq (functional-kind (node-home-lambda call)) :external)) + (not (let ((home (node-home-lambda call))) + (or (external-entry-point-p home) + (typed-entry-point-p home)))) (not *converting-for-interpreter*) (inline-expansion-ok call)) (with-ir1-environment call

commit efd05b70ebbe8f38541f295901ce46038b072a38 Author: Helmut Eller eller.helmut@gmail.com Date: Fri Jun 22 12:13:22 2012 +0200

Handle unused arguments.

* compiler/ir2tran.lisp (ir2-convert-local-typed-call): Skip over unsed args.

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index fd0855e..a796d1a 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -914,13 +914,16 @@ compilation policy") nfp number-stack-frame-size) (make-typed-call-tns ftype) (declare (ignore number-stack-frame-size)) - (let ((cont-tns (loop for arg in args - collect (continuation-tn node block arg)))) + (collect ((actuals) (arg-locs)) + (loop for arg in args for loc in arg-tns do + (when arg + (actuals (continuation-tn node block arg)) + (arg-locs loc))) (vop allocate-frame node block nil fp nfp) (vop* typed-call-local node block - (fp nfp (reference-tn-list cont-tns nil)) + (fp nfp (reference-tn-list (actuals) nil)) ((reference-tn-list result-tns t)) - arg-tns stack-frame-size start) + (arg-locs) stack-frame-size start) (move-continuation-result node block result-tns cont)))))

;;; IR2-Convert-Local-Call -- Internal

commit e81e7591484df73c3515cfe21495059b4586b364 Author: Helmut Eller eller.helmut@gmail.com Date: Fri Jun 22 12:09:49 2012 +0200

In %defun, closures and known functions are problematic. For now, disable the typed convention for them.

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index f4ce61d..e55b334 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -3994,7 +3994,9 @@ (decls (nth-value 1 (system:parse-body (cddr lambda) *lexical-environment* t))) (convention (find-declaration 'calling-convention decls 1 0))) - (cond (convention + (cond ((and convention + (not (info function info name)) + (and (null (lexenv-variables *lexical-environment*)))) (setf (info function calling-convention name) convention)) (t (clear-info function calling-convention name))) @@ -4002,7 +4004,7 @@ ;; If not in a simple environment or :notinline, then discard any forward ;; references to this function. (unless expansion (remhash name *free-functions*)) - + (let* ((var (get-defined-function name)) (save-expansion (and (member (defined-function-inlinep var) '(:inline :maybe-inline)) @@ -4014,7 +4016,7 @@ ;; obsolete. (when (eq (leaf-where-from var) :defined) (setf (leaf-type var) (specifier-type 'function))) - + (let ((fun (ir1-convert-lambda-for-defun lambda var expansion #'ir1-convert-lambda 'defun)))

commit fc5f13bfaa060e628f69b0e2c13e07b05140403b Author: Helmut Eller eller.helmut@gmail.com Date: Fri Jun 22 12:07:35 2012 +0200

Be more careful when searching the typed entry point of functions. The function might be a closure and we can't access the code object for those.

diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index 6f8063f..61725e6 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -288,11 +288,16 @@ (equal (cadr fname) name)) (return ep)))))

+(defun find-typed-entry-point-for-function (xep name) + (declare (type function xep)) + (when (= (kernel:get-type xep) vm:function-header-type) + (let ((code (function-code-header xep))) + (find-typed-entry-point-in-code code name)))) + (defun find-typed-entry-point-for-fdefn (fdefn) (let ((xep (fdefn-function fdefn))) - (when xep - (let ((code (function-code-header xep))) - (find-typed-entry-point-in-code code (fdefn-name fdefn)))))) + (when (functionp xep) + (find-typed-entry-point-for-function xep (fdefn-name fdefn)))))

;; find-typed-entry-point is called at load-time and returns the ;; fdefn that should be called. @@ -463,9 +468,8 @@ (defun check-function-redefinition (name new-fun) (multiple-value-bind (linkage foundp) (ext:info function linkage name) (when foundp - (let* ((new-code (function-code-header new-fun)) - (new-tep (find-typed-entry-point-in-code new-code name)) - (new-type (if new-tep + (let* ((new-tep (find-typed-entry-point-for-function new-fun name)) + (new-type (if new-tep (extract-function-type new-tep) (specifier-type '(function * *))))) (dolist (cs (listify (linkage-callsites linkage)))

commit 8acb0481d5312d799fb0febf43c19e1be2ae5b58 Author: Helmut Eller eller.helmut@gmail.com Date: Wed Jun 20 11:00:39 2012 +0200

In the cross-build Make-rule, build PCL too.

diff --git a/Makefile b/Makefile index f69a09f..1fe4a0a 100644 --- a/Makefile +++ b/Makefile @@ -350,14 +350,18 @@ cross-build: bin/create-target.sh xtarget cp src/tools/cross-scripts/cross-x86-x86.lisp xtarget/cross.lisp ifeq ($(XBOOTFILE),) - bin/cross-build-world.sh -crl \ + bin/cross-build-world.sh -cr \ xtarget xcross xtarget/cross.lisp $(BOOTCMUCL) else - bin/cross-build-world.sh -crl \ + bin/cross-build-world.sh -cr \ -B $(XBOOTFILE) xtarget xcross xtarget/cross.lisp $(BOOTCMUCL) endif bin/rebuild-lisp.sh xtarget bin/load-world.sh -p xtarget "newlisp" + bin/create-target.sh xstage2 + bin/build-world.sh xstage2 xtarget/lisp/lisp + bin/rebuild-lisp.sh xstage2 + bin/load-world.sh xstage2 "newlisp2"

sanity: @if [ `echo $(TOPDIR) | egrep -c '^/'` -ne 1 ]; then \

commit b15f6293c59f4ec7bd80fe2c628e29f4afae4590 Author: Helmut Eller eller.helmut@gmail.com Date: Wed Jun 20 10:59:48 2012 +0200

Load files into cross-compiler.

diff --git a/src/bootfiles/20c/tccxboot.lisp b/src/bootfiles/20c/tccxboot.lisp index e149843..d54fc23 100644 --- a/src/bootfiles/20c/tccxboot.lisp +++ b/src/bootfiles/20c/tccxboot.lisp @@ -3,7 +3,7 @@

(c::define-info-type function c::calling-convention symbol nil) (c::define-info-type function lisp::linkage lisp::linkage nil) -(delete-file (compile-file "target:compiler/knownfun")) -(delete-file (compile-file "target:code/load")) +(delete-file (compile-file "target:compiler/knownfun" :load t)) +(delete-file (compile-file "target:code/load" :load t))

commit 7bc1550b6965f3399f66d5d1c8eb30c3b242b914 Author: Helmut Eller eller.helmut@gmail.com Date: Wed Jun 20 10:57:03 2012 +0200

Some small improvements in the linker code.

* code/fdenition.lisp (find-typed-entry-point): Enable sharing of callsite objects if the types match. (generate-adapter-function): Bind *derive-function-types* for stricter type checks. (check-function-redefinition): Handle case where the new function doesn't have an entry point. Also use (:adapter <foo>) as name for adapter functions. (patch-fdefn): Take name as optional argument.

diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index 89d1b4e..6f8063f 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -325,10 +325,10 @@ (cond (foundp info) (t (setf (ext:info function linkage name) (make-linkage))))))) - (cond ((and nil (dolist (cs (listify (linkage-callsites linkage))) + (cond ((dolist (cs (listify (linkage-callsites linkage))) (let* ((ep-type (callsite-type cs))) (when (function-types-compatible-p cs-type ep-type) - (return (callsite-fdefn cs))))))) + (return (callsite-fdefn cs)))))) ((let ((fdefn (fdefinition-object name nil))) (when fdefn (let ((fun (find-typed-entry-point-for-fdefn fdefn))) @@ -388,6 +388,7 @@ (declare (type function-type ftype)) (let* ((atypes (function-type-required ftype)) (tmps (loop for nil in atypes collect (gensym))) + (*derive-function-types* nil) (fun (compile nil `(lambda ,tmps @@ -464,7 +465,9 @@ (when foundp (let* ((new-code (function-code-header new-fun)) (new-tep (find-typed-entry-point-in-code new-code name)) - (new-type (extract-function-type new-tep))) + (new-type (if new-tep + (extract-function-type new-tep) + (specifier-type '(function * *))))) (dolist (cs (listify (linkage-callsites linkage))) (let ((cs-type (callsite-type cs)) (fdefn (callsite-fdefn cs))) @@ -473,16 +476,16 @@ ((dolist (fun (listify (linkage-adapters linkage))) (let ((ep-type (kernel:extract-function-type fun))) (when (function-types-compatible-p cs-type ep-type) - (patch-fdefn fdefn fun) + (patch-fdefn fdefn fun `(:adapter ,name)) (return t))))) (t (let ((fun (generate-adapter-function cs-type name))) (push-unlistified fun (linkage-adapters linkage)) - (patch-fdefn fdefn fun)))))))))) + (patch-fdefn fdefn fun `(:adapter ,name)))))))))))

-(defun patch-fdefn (fdefn new-fun) +(defun patch-fdefn (fdefn new-fun &optional name) (setf (kernel:fdefn-function fdefn) new-fun) - (let ((name (kernel:%function-name new-fun))) + (let ((name (or name (kernel:%function-name new-fun)))) (kernel:%set-fdefn-name fdefn name)) fdefn)

commit 376e5ea8fccf76f1ecaab4ebb2c0e0aa80bd1809 Author: Helmut Eller eller.helmut@gmail.com Date: Wed Jun 20 10:53:06 2012 +0200

Add support for wild/unknown return types.

* compiler/x86/call.lisp (make-typed-call-tns): If the number of return values is not fixed return the symbol :unknown instead of a list of TNs.

* compiler/gtn.lisp (return-info-for-typed-entry-point): For :unknown number of return values use the standard return convention.

* compiler/ir2tran.lisp ([ir2convert] %typed-call): Generate different code for :unknown number of return values.

* compiler/x86/call.lisp ([vop] typed-call-named): Take an additional info argument NRESULTS that indicates that we should use standard return convention.

* compiler/x86/call.lisp ([vop] multiple-typed-call-named): New vop.

diff --git a/src/compiler/gtn.lisp b/src/compiler/gtn.lisp index fee6afa..1cc15bf 100644 --- a/src/compiler/gtn.lisp +++ b/src/compiler/gtn.lisp @@ -240,10 +240,14 @@ (declare (type clambda fun)) (let* ((ftype (typed-entry-point-type fun)) (tns (nth-value 1 (make-typed-call-tns ftype)))) - (make-return-info :kind :fixed - :count (length tns) - :types (mapcar #'tn-primitive-type tns) - :locations tns))) + (etypecase tns + ((eql :unknown) + (return-info-for-set (lambda-tail-set fun))) + (list + (make-return-info :kind :fixed + :count (length tns) + :types (mapcar #'tn-primitive-type tns) + :locations tns)))))

;;; Assign-Return-Locations -- Internal ;;; diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 9328298..fd0855e 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -1780,22 +1780,38 @@ compilation policy") (defoptimizer (%typed-call ir2-convert) ((&rest args) node block) (let* ((fun (combination-fun node)) (ftype (continuation-derived-type fun)) - (cont (node-cont node))) + (cont (node-cont node)) + (2cont (continuation-info cont))) (check-type ftype function-type) (multiple-value-bind (arg-tns result-tns fp stack-frame-size nfp number-stack-frame-size) (make-typed-call-tns ftype) (declare (ignore number-stack-frame-size)) - (let ((fdefn-tn (typed-entry-point-continuation-tn fun ftype)) - (cont-tns (loop for arg in args - collect (continuation-tn node block arg)))) + (let* ((fdefn-tn (typed-entry-point-continuation-tn fun ftype)) + (cont-tns (loop for arg in args + collect (continuation-tn node block arg))) + (arg-refs (reference-tn-list cont-tns nil))) (vop allocate-frame node block nil fp nfp) - (vop* typed-call-named node block - (fp nfp fdefn-tn (reference-tn-list cont-tns nil)) - ((reference-tn-list result-tns t)) - arg-tns stack-frame-size) - (move-continuation-result node block result-tns cont))))) + (cond ((and 2cont (eq (ir2-continuation-kind 2cont) :unknown)) + (assert (eq result-tns :unknown)) + (vop* x86::multiple-typed-call-named node block + (fp nfp fdefn-tn arg-refs) + ((reference-tn-list (ir2-continuation-locs 2cont) t)) + arg-tns stack-frame-size)) + ((eq result-tns :unknown) + (let ((locs (standard-result-tns cont))) + (vop* typed-call-named node block + (fp nfp fdefn-tn arg-refs) + ((reference-tn-list locs t)) + arg-tns stack-frame-size (length locs)) + (move-continuation-result node block locs cont))) + (t + (vop* typed-call-named node block + (fp nfp fdefn-tn arg-refs) + ((reference-tn-list result-tns t)) + arg-tns stack-frame-size nil) + (move-continuation-result node block result-tns cont)))))))

;;; IR2-Convert -- Interface diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 90d9259..cad0b46 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -234,16 +234,19 @@ '(double-reg descriptor-reg))) tn))) (let* ((arg-state (list :frame-size 2 :xmms-reg xmm4-offset :reg-args 0)) - (ret-state (list :frame-size 2 :xmms-reg xmm4-offset :reg-args 0)) - (returns (function-type-returns ftype)) - (rtypes (typecase returns - (values-type (values-type-required returns)) - (t (list returns))))) + (ret-state (list :frame-size 2 :xmms-reg xmm4-offset :reg-args 0))) (values - (loop for type in (function-type-required ftype) - collect (arg-tn type arg-state)) - (loop for type in rtypes - collect (ret-tn type ret-state)) + (multiple-value-bind (min max) (function-type-nargs ftype) + (assert (and min max (= min max)) () + "Only fixed number of arguments supported (currently)") + (loop for type in (function-type-required ftype) + collect (arg-tn type arg-state))) + (multiple-value-bind (types count) + (values-types (function-type-returns ftype)) + (cond ((eq count :unknown) :unknown) + (t + (loop for type in types + collect (ret-tn type ret-state))))) (x86-make-stack-pointer-tn) (max (getf arg-state :frame-size) (getf ret-state :frame-size)) @@ -1159,8 +1162,8 @@ (:save-p t) (:move-args :local-call) (:vop-var vop) - (:info arg-locs real-frame-size) - (:ignore new-nfp args arg-locs results) + (:info arg-locs real-frame-size nresults) + (:ignore new-nfp args arg-locs) (:temporary (:sc descriptor-reg :offset eax-offset) eax) (:generator 30 @@ -1186,8 +1189,52 @@ (inst call (make-ea :dword :base eax :disp (- (* fdefn-raw-addr-slot word-bytes) other-pointer-type))) + (when nresults + (default-unknown-values vop results nresults))

)) + +(define-vop (multiple-typed-call-named unknown-values-receiver) + (:args (new-fp) + (new-nfp) + (fdefn :scs (descriptor-reg control-stack) + :target eax) + (args :more t :scs (descriptor-reg))) + (:temporary (:sc descriptor-reg :offset eax-offset) + eax) + (:save-p t) + (:move-args :local-call) + (:info arg-locs real-frame-size) + (:ignore new-nfp args arg-locs) + (:vop-var vop) + (:generator 30 + ;; FIXME: allocate the real frame size here. We had to emit + ;; ALLOCATE-FRAME before this vop so that we can use the + ;; (:move-args :local-call) option here. Without the + ;; ALLOCATE-FRAME vop we get a failed assertion. + (inst lea esp-tn (make-ea :dword :base new-fp + :disp (- (* real-frame-size word-bytes)))) + + ;; Move fdefn to eax before switching frames. + (move eax fdefn) + + ;; Write old frame pointer (epb) into new frame. + (storew ebp-tn new-fp (- (1+ ocfp-save-offset))) + + ;; Switch to new frame. + (move ebp-tn new-fp) + + (note-this-location vop :call-site) + + ;; Load address out of fdefn and call it. + (inst call (make-ea :dword :base eax + :disp (- (* fdefn-raw-addr-slot word-bytes) + other-pointer-type))) + + (note-this-location vop :unknown-return) + (receive-unknown-values values-start nvals start count) + (trace-table-entry trace-table-normal))) +  ;;;; Unknown values return:

commit 6b3aba66b6756339a54ca4bdcea43d6b0db807d1 Author: Helmut Eller eller.helmut@gmail.com Date: Sun Jun 17 21:04:47 2012 +0200

Pass XBOOTFILE as argument to cross-build-world.sh

diff --git a/Makefile b/Makefile index 98024b4..f69a09f 100644 --- a/Makefile +++ b/Makefile @@ -349,7 +349,13 @@ cross-build: bin/create-target.sh xcross bin/create-target.sh xtarget cp src/tools/cross-scripts/cross-x86-x86.lisp xtarget/cross.lisp - bin/cross-build-world.sh xtarget xcross xtarget/cross.lisp $(BOOTCMUCL) +ifeq ($(XBOOTFILE),) + bin/cross-build-world.sh -crl \ + xtarget xcross xtarget/cross.lisp $(BOOTCMUCL) +else + bin/cross-build-world.sh -crl \ + -B $(XBOOTFILE) xtarget xcross xtarget/cross.lisp $(BOOTCMUCL) +endif bin/rebuild-lisp.sh xtarget bin/load-world.sh -p xtarget "newlisp"

commit 60a63d8efa0d7f0129b1a5466d45e84daff84f09 Author: Helmut Eller eller.helmut@gmail.com Date: Sun Jun 17 21:02:17 2012 +0200

Use compile-file instead of comf in boot file.

diff --git a/src/bootfiles/20c/tccxboot.lisp b/src/bootfiles/20c/tccxboot.lisp index fb1eb81..e149843 100644 --- a/src/bootfiles/20c/tccxboot.lisp +++ b/src/bootfiles/20c/tccxboot.lisp @@ -3,4 +3,7 @@

(c::define-info-type function c::calling-convention symbol nil) (c::define-info-type function lisp::linkage lisp::linkage nil) -(comf "target:code/load" :load t) +(delete-file (compile-file "target:compiler/knownfun")) +(delete-file (compile-file "target:code/load")) + +

commit dadf9066b180da5b52341651f63353b25ac85fbb Author: Helmut Eller eller.helmut@gmail.com Date: Sun Jun 17 21:01:17 2012 +0200

Use :typed-no-xep convention when creating for adapters.

diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index db55172..89d1b4e 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -290,8 +290,9 @@

(defun find-typed-entry-point-for-fdefn (fdefn) (let ((xep (fdefn-function fdefn))) - (let ((code (function-code-header xep))) - (find-typed-entry-point-in-code code (fdefn-name fdefn))))) + (when xep + (let ((code (function-code-header xep))) + (find-typed-entry-point-in-code code (fdefn-name fdefn))))))

;; find-typed-entry-point is called at load-time and returns the ;; fdefn that should be called. @@ -370,6 +371,12 @@ (declare (ignore args)) (error "Linking callsite to typed-entry-point failed"))

+(defun validate-adapter-type (fun ftype) + (let ((etype (extract-function-type fun))) + (unless (function-types-compatible-p ftype etype t) + (break))) + fun) + ;; Generate an adapter function that changes the representation of the ;; arguments (specified with FTYPE) and forwards the call to NAME. ;; The adapter has also a typed entry point. It should also check @@ -378,31 +385,22 @@ ;; In practice, the compiler infered type may not match exactly FTYPE, ;; even if we add lotso declarations. This is annyoingly brittle. (defun generate-adapter-function (ftype name) - (let* ((atypes (kernel:function-type-required ftype)) + (declare (type function-type ftype)) + (let* ((atypes (function-type-required ftype)) (tmps (loop for nil in atypes collect (gensym))) - (fname `(:typed-entry-point - :boxing-adapter ,(make-symbol (string name)))) - (ftypespec (kernel:type-specifier ftype))) - (proclaim `(ftype ,ftypespec ,fname)) - (compile fname - `(lambda ,tmps - (declare - ,@(loop for tmp in tmps - for type in atypes - collect `(type ,(kernel:type-specifier type) ,tmp))) - (the ,(kernel:type-specifier - (kernel:function-type-returns ftype)) - (funcall (function ,name) . ,tmps)))) - (let ((fun (fdefinition fname))) - (unless (eq name 'linkage-error) - (fix-ftype fun ftype)) - fun))) - -(defun fix-ftype (fun ftype) - (let ((etype (kernel:extract-function-type fun))) - (unless (function-types-compatible-p ftype etype t) - (break))) - fun) + (fun (compile + nil + `(lambda ,tmps + (declare + (c::calling-convention :typed-no-xep) + ,@(loop for tmp in tmps + for type in atypes + collect `(type ,(kernel:type-specifier type) ,tmp))) + (the ,(kernel:type-specifier + (kernel:function-type-returns ftype)) + (funcall (function ,name) . ,tmps)))))) + (validate-adapter-type fun ftype) + fun))

;; This is our rule to decide when a type at a callsite matches the ;; type of the entry point.

commit 19eb5e3a6e0c3146bae8787e469610c9f2778a14 Author: Helmut Eller eller.helmut@gmail.com Date: Sun Jun 17 20:02:47 2012 +0200

Call :typed-no-xep functions like the :typed convention.

This probably doesn't come up in practise but may be useful for testing.

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 1ded755..9cb17ab 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -952,9 +952,10 @@ (cc (info function calling-convention name)) (info (ecase cc ((nil) info) - (:typed (cond ((not info) - (info function info '%typed-call)) - (t (error "nyi"))))))) + ((:typed :typed-no-xep) + (cond ((not info) + (info function info '%typed-call)) + (t (error "nyi"))))))) (if info (values leaf (setf (basic-combination-kind call) info)) (values leaf nil)))))))

commit c5794cf2d324ee899984b67911e37df4a8c6b66d Author: Helmut Eller eller.helmut@gmail.com Date: Sun Jun 17 19:59:12 2012 +0200

Handle new cases for the :typed-no-xep.

Some lambdas are now both external-entry-point-p and typed-entry-point-p and we need to handle those cases a bit more carefully.

diff --git a/src/compiler/entry.lisp b/src/compiler/entry.lisp index 8a8c18f..48f5c96 100644 --- a/src/compiler/entry.lisp +++ b/src/compiler/entry.lisp @@ -38,7 +38,7 @@ (setf (leaf-info fun) (make-entry-info))))) (compute-entry-info fun info) (push info (ir2-component-entries 2comp)) - (when (getf (lambda-plist fun) :entry-point) + (when (typed-entry-point-p fun) (setf (getf (lambda-plist fun) :code-start) (gen-label)))))))

(select-component-format component) diff --git a/src/compiler/gtn.lisp b/src/compiler/gtn.lisp index 39d9b17..fee6afa 100644 --- a/src/compiler/gtn.lisp +++ b/src/compiler/gtn.lisp @@ -50,11 +50,10 @@ ;;; (defun assign-lambda-var-tns (fun let-p) (declare (type clambda fun)) - (ecase (getf (lambda-plist fun) :entry-point) - ((nil) - (assign-normal-lambda-var-tns fun let-p)) - (:typed - (assign-typed-lambda-var-tns fun))) + (cond ((typed-entry-point-p fun) + (assign-typed-lambda-var-tns fun)) + (t + (assign-normal-lambda-var-tns fun let-p))) (undefined-value))

(defun assign-normal-lambda-var-tns (fun let-p) @@ -77,7 +76,7 @@

(defun assign-typed-lambda-var-tns (fun) (declare (type clambda fun)) - (let ((ftype (lambda-type fun))) + (let ((ftype (typed-entry-point-type fun))) (loop for var in (lambda-vars fun) for tn in (make-typed-call-tns ftype) do (when (leaf-refs var) @@ -206,18 +205,16 @@ ;;; (defun choose-return-locations (fun) (declare (type clambda fun)) - (ecase (getf (lambda-plist fun) :entry-point) - ((nil) - (let* ((tails (lambda-tail-set fun)) - (ep (find-if (lambda (fun) - (getf (lambda-plist fun) :entry-point)) - (tail-set-functions tails)))) - (cond (ep - (return-info-for-typed-convention ep)) - (t - (return-info-for-set tails))))) - (:typed - (return-info-for-typed-convention fun)))) + (cond ((typed-entry-point-p fun) + (return-info-for-typed-entry-point fun)) + (t + (let* ((tails (lambda-tail-set fun)) + (ep (find-if #'typed-entry-point-p + (tail-set-functions tails)))) + (cond (ep + (return-info-for-typed-entry-point ep)) + (t + (return-info-for-set tails)))))))

(defun return-info-for-set (tails) (declare (type tail-set tails)) @@ -235,9 +232,13 @@ :types ptypes :locations (mapcar #'make-normal-tn ptypes))))))

-(defun return-info-for-typed-convention (fun) +(defun typed-entry-point-type (fun) (declare (type clambda fun)) - (let* ((ftype (lambda-type fun)) + (lambda-type (lambda-entry-function fun))) + +(defun return-info-for-typed-entry-point (fun) + (declare (type clambda fun)) + (let* ((ftype (typed-entry-point-type fun)) (tns (nth-value 1 (make-typed-call-tns ftype)))) (make-return-info :kind :fixed :count (length tns) @@ -260,7 +261,8 @@ (return (lambda-return fun))) (when (and return (not (eq (return-info-kind returns) :unknown)) - (external-entry-point-p fun)) + (external-entry-point-p fun) + (not (typed-entry-point-p fun))) (do-uses (use (return-result return)) (setf (node-tail-p use) nil)))) (undefined-value)) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index d1aa8b5..9328298 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -1232,13 +1232,14 @@ compilation policy") (assert (member (functional-kind fun) '(nil :external :optional :top-level :cleanup)))

- (when (external-entry-point-p fun) + (when (and (external-entry-point-p fun) + (not (typed-entry-point-p fun))) (init-xep-environment node block fun) (when *collect-dynamic-statistics* (vop count-me node block *dynamic-counts-tn* (block-number (ir2-block-block block)))))

- (when (getf (lambda-plist fun) :entry-point) + (when (typed-entry-point-p fun) (init-typed-entry-point-environment node block fun))

(emit-move node block (ir2-environment-return-pc-pass env)

commit d6c4b0fb87a0b480ddd12108d7800724c5fcfc34 Author: Helmut Eller eller.helmut@gmail.com Date: Sun Jun 17 19:54:35 2012 +0200

Don't create a XEP for the :typed-no-xep calling convention.

The :typed-no-xep convention is intended for adapter functions where the general XEP would not be used. Naming is a bit confusing now as those typed entry points actually have the lambda-kind :external so external-entry-point-p and typed-entry-point-p both return true.

diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 6882f92..d2e8d3e 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -161,7 +161,22 @@ ,tmp))) (%funcall ,fun . ,temps))))) (setf (lambda-entry-function fun) fun2) - fun2))))) + fun2)) + (:typed-no-xep + (return-from make-xep-lambda + `(lambda ,temps + (declare (entry-point :typed) + ,@(loop for tmp in temps + for var in (lambda-vars fun) + collect + `(type ,(type-specifier + (lambda-var-type var)) + ,tmp))) + (the ,(type-specifier + (continuation-asserted-type + (return-result + (lambda-return fun)))) + (%funcall ,fun . ,temps)))))))) `(lambda (,n-supplied . ,temps) (declare (type index ,n-supplied)) ,(if (policy nil (zerop safety))

commit 617698bba6f63bed808d859f559bd73c503a7837 Author: Helmut Eller eller.helmut@gmail.com Date: Sun Jun 17 09:39:25 2012 +0200

Add unsafe setter %set-fdefn-name.

That's useful for debugging.

diff --git a/src/bootfiles/20c/tccxboot.lisp b/src/bootfiles/20c/tccxboot.lisp index f9e50e2..fb1eb81 100644 --- a/src/bootfiles/20c/tccxboot.lisp +++ b/src/bootfiles/20c/tccxboot.lisp @@ -3,5 +3,4 @@

(c::define-info-type function c::calling-convention symbol nil) (c::define-info-type function lisp::linkage lisp::linkage nil) -(comf "target:code/fdefinition" :load t) (comf "target:code/load" :load t) diff --git a/src/code/exports.lisp b/src/code/exports.lisp index 060ad89..865b6e1 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -2261,8 +2261,8 @@ "VALUES-TYPE-REQUIRED" "VALUES-TYPE-REST" "VALUES-TYPE-UNION" "VALUES-TYPES" "VALUES-TYPES-INTERSECT" "VOID" "WITH-CIRCULARITY-DETECTION" "WRONG-NUMBER-OF-INDICES-ERROR" - "FDEFN" "MAKE-FDEFN" "FDEFN-P" "FDEFN-NAME" "FDEFN-FUNCTION" - "FDEFN-OR-LOSE" + "FDEFN" "MAKE-FDEFN" "FDEFN-P" "FDEFN-NAME" "%SET-FDEFN-NAME" + "FDEFN-FUNCTION" "FDEFN-OR-LOSE" "FDEFN-MAKUNBOUND" "%COERCE-TO-FUNCTION" "FUNCTION-SUBTYPE" "*MAXIMUM-ERROR-DEPTH*" "%SET-SYMBOL-PLIST" "INFINITE-ERROR-PROTECT" diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index 3555372..db55172 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -482,17 +482,10 @@ (push-unlistified fun (linkage-adapters linkage)) (patch-fdefn fdefn fun))))))))))

-;; This lets us set the name in fdefn objects. We use that for -;; debugging. -#-bootstrap -(eval-when (:compile-toplevel) - (c:defknown set-fdefn-name (kernel:fdefn t) t) - (c:def-setter set-fdefn-name vm:fdefn-name-slot vm:other-pointer-type)) - (defun patch-fdefn (fdefn new-fun) (setf (kernel:fdefn-function fdefn) new-fun) (let ((name (kernel:%function-name new-fun))) - (set-fdefn-name fdefn name)) + (kernel:%set-fdefn-name fdefn name)) fdefn)

(pushnew 'check-function-redefinition ext:*setf-fdefinition-hook*) diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index da04b4f..5c912a6 100644 --- a/src/compiler/generic/objdef.lisp +++ b/src/compiler/generic/objdef.lisp @@ -306,7 +306,7 @@ (define-primitive-object (fdefn :type fdefn :lowtag other-pointer-type :header fdefn-type) - (name :ref-trans fdefn-name) + (name :ref-trans fdefn-name :set-trans %set-fdefn-name :set-known (unsafe)) (function :type (or function null) :ref-trans fdefn-function) (raw-addr :c-type #-alpha "char *" #+alpha "u32"))

commit 186d3c0814b3e0db9662f84b3fefb1b049bfe790 Author: Helmut Eller eller.helmut@gmail.com Date: Sat Jun 16 23:56:30 2012 +0200

In comf, enter the debugger before Error Aborts.

diff --git a/src/tools/setup.lisp b/src/tools/setup.lisp index 2e0cf1c..9277b55 100644 --- a/src/tools/setup.lisp +++ b/src/tools/setup.lisp @@ -282,6 +282,7 @@ (error (condition) (declare (ignore condition)) (format t "Error in backtrace!~%"))) + (break condition) (format t "Error abort.~%") (return-from comf))))) (if assem

commit d367449f21e17828dbc48f6da1ec7dfc88a9881e Author: Helmut Eller eller.helmut@gmail.com Date: Sat Jun 16 23:52:11 2012 +0200

Add bootfiles/20c/tccxboot.lisp and using for the build. In tools/cross-scripts/cross-x86-x86.lisp remove the code that imports symbols from OLD-X86 into X86. We don't want genesis to dump the OLD-X86 package.

diff --git a/Makefile b/Makefile index 808ba2a..98024b4 100644 --- a/Makefile +++ b/Makefile @@ -7,6 +7,7 @@ BUILDDIR := $(TOPDIR)/build BOOTCMUCL := cmucl XHOST := x86 XTARGET := x86 +XBOOTFILE := BOOTFILE :=

help: @@ -33,14 +34,15 @@ BUILDDIR build directory ($(BUILDDIR))\n\ BOOTCMUCL compiler used for bootstrap ($(BOOTCMUCL))\n\ XHOST host system ($(XHOST))\n\ XTARGET target system ($(XTARGET))\n\ -BOOTFILE file for bootstrap hacks (default: none)\ +XBOOTFILE file to execute before building cross-compiler (default: none)\n\ +BOOTFILE file to initialize compiler (default: none)\ "

help-other: @echo -e "\ -xcompile-world -- cross-compile library \n\ +xcompile-world -- cross-compile core components (no compiler) \n\ xcompile-compiler -- cross-compile compiler \n\ -xdump-world -- cold-load library and cross-dump (genesis)\n\ +xdump-world -- genesis (emulate loading then dump the emulated heap)\n\ clean-world -- remove the build/world directory\n\ sanity-clean -- remove fasl files in source directory\n\ run-xcompiler -- open a REPL with the cross-compiler\ @@ -93,6 +95,12 @@ LOAD_BOOTFILE=' \ (load bootfile))) \ '

+LOAD_XBOOTFILE=' \ +(let ((bootfile "$(XBOOTFILE)")) \ + (unless (equal bootfile "") \ + (load bootfile))) \ +' + SET_TARGET_SEARCH_LIST=(setf (ext:search-list "target:") (list $(1) "src/"))

XSETENV=' \ @@ -184,6 +192,7 @@ $(BUILDDIR)/xcompiler/cross-%.core: -eval '(load "target:tools/setup" :if-source-newer :load-source)' \ -eval '(comf "target:tools/setup" :load t)' \ -eval '(setq *gc-verbose* nil *interactive* nil)' \ +-eval $(LOAD_XBOOTFILE) \ -eval '(load "$(XCOMPILERDIR)/cross.lisp")' \ -eval '(remf ext::*herald-items* :python)' \ -eval '(ext:save-lisp "$@" :purify nil)' \ diff --git a/src/bootfiles/20c/tccxboot.lisp b/src/bootfiles/20c/tccxboot.lisp new file mode 100644 index 0000000..f9e50e2 --- /dev/null +++ b/src/bootfiles/20c/tccxboot.lisp @@ -0,0 +1,7 @@ + +;; boot file for cross-compiler to add typed calling convention. + +(c::define-info-type function c::calling-convention symbol nil) +(c::define-info-type function lisp::linkage lisp::linkage nil) +(comf "target:code/fdefinition" :load t) +(comf "target:code/load" :load t) diff --git a/src/tools/cross-scripts/cross-x86-x86.lisp b/src/tools/cross-scripts/cross-x86-x86.lisp index 87c2dad..afe7dfa 100644 --- a/src/tools/cross-scripts/cross-x86-x86.lisp +++ b/src/tools/cross-scripts/cross-x86-x86.lisp @@ -37,20 +37,14 @@ (pushnew :bootstrap *features*) (pushnew :building-cross-compiler *features*)

-;; Make fixup-code-object and sanctify-for-execution in the VM package -;; be the same as the original. Needed to get rid of a compiler error -;; in generic/core.lisp. (This halts cross-compilations if the -;; compiling lisp uses the -batch flag. -(import 'old-vm::fixup-code-object "VM") -(import 'old-vm::sanctify-for-execution "VM") -(export 'vm::fixup-code-object "VM") -(export 'vm::sanctify-for-execution "VM") - -;; -(unless (find "CALLING-CONVENTION" - (c::class-info-types (gethash "FUNCTION" c::*info-classes*)) - :key #'c::type-info-name :test #'equal) - (c::define-info-type function c::calling-convention symbol nil)) +;;;; Make fixup-code-object and sanctify-for-execution in the VM package +;;;; be the same as the original. Needed to get rid of a compiler error +;;;; in generic/core.lisp. (This halts cross-compilations if the +;;;; compiling lisp uses the -batch flag. +;;(import 'old-vm::fixup-code-object "VM") +;;(import 'old-vm::sanctify-for-execution "VM") +;;(export 'vm::fixup-code-object "VM") +;;(export 'vm::sanctify-for-execution "VM")

(comf "target:code/exports")

@@ -224,3 +218,4 @@ (setf (gethash 'old-vm::any-reg ht) (gethash 'vm::any-reg ht)))

+(delete-package "OLD-X86")

commit 340d7957960208ecfb59f69b8f76a15792a842d9 Author: Helmut Eller eller.helmut@gmail.com Date: Sat Jun 16 23:50:25 2012 +0200

Add runtime support for linking. For now that code lives in code/fdefinition.lisp.

diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index b7a4033..3555372 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -255,3 +255,244 @@ (fdefn-makunbound fdefn))) (kernel:undefine-function-name name) name) + + + +(defstruct callsite + (type (ext:required-argument) :type kernel:function-type :read-only t) + (fdefn (ext:required-argument) :type kernel:fdefn :read-only t)) + +(defstruct linkage + (callsites nil :type (or callsite list)) + (adapters nil :type (or function list))) + +(defun listify (x) + (if (listp x) x (list x))) + +(defmacro push-unlistified (new-value (reader object)) + `(let ((new-value ,new-value) (object ,object)) + (let ((old-value (,reader ,object))) + (setf (,reader object) + (typecase old-value + (null new-value) + (cons (cons new-value old-value)) + (t (list new-value old-value))))))) + +(defun find-typed-entry-point-in-code (code name) + (loop for ep = (%code-entry-points code) then (%function-next ep) + while ep do + (let ((fname (%function-name ep))) + (when (and (consp fname) + (eq (car fname) :typed-entry-point) + (consp (cdr fname)) + (equal (cadr fname) name)) + (return ep))))) + +(defun find-typed-entry-point-for-fdefn (fdefn) + (let ((xep (fdefn-function fdefn))) + (let ((code (function-code-header xep))) + (find-typed-entry-point-in-code code (fdefn-name fdefn))))) + +;; find-typed-entry-point is called at load-time and returns the +;; fdefn that should be called. +;; +;; 1. We go through the list of existing callsites to see if we +;; already have one with the same type and reuse it if possible. +;; +;; 2. We look at the current definition. If the types match, we +;; create a callsite object, store it in the info db, and return the +;; fdefn. +;; +;; 3. Now we know that the types don't match we need to use adapters. +;; First again, we look at existing adapters and reuse them if possible. +;; +;; 4. An adapter is created that boxes the arguments and forwards the +;; call to the "normal" entry point. +;; +;; 5. If we are not allowed to create adapters, we look again at the +;; current definition to handle the case where no current definition +;; exists. If so, we return an empty fdefn object that will call the +;; undefined-tramp assembly routine. +;; +;; 6. If all else fails we link the callsite to our error handler. +;; +(declaim (ftype (function (t t) kernel:fdefn) find-typed-entry-point)) +(defun find-typed-entry-point (name callsite-typespec) + (let* ((cs-type (kernel:specifier-type callsite-typespec)) + (linkage (multiple-value-bind (info foundp) + (ext:info function linkage name) + (cond (foundp info) + (t (setf (ext:info function linkage name) + (make-linkage))))))) + (cond ((and nil (dolist (cs (listify (linkage-callsites linkage))) + (let* ((ep-type (callsite-type cs))) + (when (function-types-compatible-p cs-type ep-type) + (return (callsite-fdefn cs))))))) + ((let ((fdefn (fdefinition-object name nil))) + (when fdefn + (let ((fun (find-typed-entry-point-for-fdefn fdefn))) + (when fun + (let ((ep-type (kernel:extract-function-type fun))) + (when (function-types-compatible-p cs-type ep-type) + (let* ((aname (kernel:%function-name fun)) + (fdefn (kernel:make-fdefn aname)) + (cs (make-callsite :type cs-type :fdefn fdefn))) + (setf (kernel:fdefn-function fdefn) fun) + (push-unlistified cs (linkage-callsites linkage)) + fdefn)))))))) + ((or (not (lisp::fdefinition-object name nil)) + (not (kernel:fdefn-function + (lisp::fdefinition-object name nil)))) + (let* ((aname `(:typed-entry-point #:undefined)) + (fdefn (kernel:make-fdefn aname)) + (cs (make-callsite :type cs-type :fdefn fdefn))) + (push-unlistified cs (linkage-callsites linkage)) + fdefn)) + ((dolist (fun (listify (linkage-adapters linkage))) + (let ((ep-type (kernel:extract-function-type fun))) + (when (function-types-compatible-p cs-type ep-type) + (let* ((aname (kernel:%function-name fun)) + (fdefn (kernel:make-fdefn aname)) + (cs (make-callsite :type cs-type :fdefn fdefn))) + (setf (kernel:fdefn-function fdefn) fun) + (push-unlistified cs (linkage-callsites linkage)) + (return fdefn)))))) + (t + (let* ((fun (generate-adapter-function cs-type name)) + (fdefn (kernel:make-fdefn (kernel:%function-name fun))) + (cs (make-callsite :type cs-type :fdefn fdefn))) + (setf (kernel:fdefn-function fdefn) fun) + (push-unlistified fun (linkage-adapters linkage)) + (push-unlistified cs (linkage-callsites linkage)) + fdefn))))) + +(defun linkage-error (&rest args) + (declare (ignore args)) + (error "Linking callsite to typed-entry-point failed")) + +;; Generate an adapter function that changes the representation of the +;; arguments (specified with FTYPE) and forwards the call to NAME. +;; The adapter has also a typed entry point. It should also check +;; that the values returned by NAME match FTYPE. +;; +;; In practice, the compiler infered type may not match exactly FTYPE, +;; even if we add lotso declarations. This is annyoingly brittle. +(defun generate-adapter-function (ftype name) + (let* ((atypes (kernel:function-type-required ftype)) + (tmps (loop for nil in atypes collect (gensym))) + (fname `(:typed-entry-point + :boxing-adapter ,(make-symbol (string name)))) + (ftypespec (kernel:type-specifier ftype))) + (proclaim `(ftype ,ftypespec ,fname)) + (compile fname + `(lambda ,tmps + (declare + ,@(loop for tmp in tmps + for type in atypes + collect `(type ,(kernel:type-specifier type) ,tmp))) + (the ,(kernel:type-specifier + (kernel:function-type-returns ftype)) + (funcall (function ,name) . ,tmps)))) + (let ((fun (fdefinition fname))) + (unless (eq name 'linkage-error) + (fix-ftype fun ftype)) + fun))) + +(defun fix-ftype (fun ftype) + (let ((etype (kernel:extract-function-type fun))) + (unless (function-types-compatible-p ftype etype t) + (break))) + fun) + +;; This is our rule to decide when a type at a callsite matches the +;; type of the entry point. +;; +;; 1. The arguments at the callsite should be subtypes of the +;; arguments at the entry point. +;; +;; 2. The return value at the callsite should be supertypes of the +;; return values at the entry point. +;; +;; 3. The representations must agree. Representations should probably +;; decided in the backend, but for now we assume only double-floats +;; are unboxed. +(defun function-types-compatible-p (callsite-type entrypoint-type + &optional ignore-representation) + (flet ((return-types (ftype) + (let ((type (kernel:function-type-returns ftype))) + (cond ((kernel:values-type-p type) + (assert (and (not (kernel:values-type-rest type)) + (not (kernel:values-type-keyp type)))) + (kernel:values-type-required type)) + (t + (list type))))) + (ptype= (type1 type2) + (let ((double-float (kernel:specifier-type 'double-float))) + (cond (ignore-representation t) + ((kernel:type= type1 double-float) + (kernel:type= type2 double-float)) + ((kernel:type= type2 double-float) + nil) + (t t))))) + (and (every #'kernel:csubtypep + (kernel:function-type-required callsite-type) + (kernel:function-type-required entrypoint-type)) + (every #'ptype= + (kernel:function-type-required callsite-type) + (kernel:function-type-required entrypoint-type)) + (or + (and (every #'kernel:csubtypep + (return-types entrypoint-type) + (return-types callsite-type)) + (every #'ptype= + (return-types entrypoint-type) + (return-types callsite-type))) + (kernel:type= (kernel:function-type-returns entrypoint-type) + (kernel:specifier-type 'nil)))))) + + +;; check-function-redefinition is used as setf-fdefinition-hook. +;; We go through all existing callsites and +;; +;; 1. If the new type matches, we patch the callsite with the new function. +;; +;; 2. If the types don't match and if allowed, we redirect the +;; callsite to and adapter. +;; +;; 3. If the callsites doesn't want adapters we link the callsite to +;; an error handler. +(defun check-function-redefinition (name new-fun) + (multiple-value-bind (linkage foundp) (ext:info function linkage name) + (when foundp + (let* ((new-code (function-code-header new-fun)) + (new-tep (find-typed-entry-point-in-code new-code name)) + (new-type (extract-function-type new-tep))) + (dolist (cs (listify (linkage-callsites linkage))) + (let ((cs-type (callsite-type cs)) + (fdefn (callsite-fdefn cs))) + (cond ((function-types-compatible-p cs-type new-type) + (patch-fdefn fdefn new-tep)) + ((dolist (fun (listify (linkage-adapters linkage))) + (let ((ep-type (kernel:extract-function-type fun))) + (when (function-types-compatible-p cs-type ep-type) + (patch-fdefn fdefn fun) + (return t))))) + (t + (let ((fun (generate-adapter-function cs-type name))) + (push-unlistified fun (linkage-adapters linkage)) + (patch-fdefn fdefn fun)))))))))) + +;; This lets us set the name in fdefn objects. We use that for +;; debugging. +#-bootstrap +(eval-when (:compile-toplevel) + (c:defknown set-fdefn-name (kernel:fdefn t) t) + (c:def-setter set-fdefn-name vm:fdefn-name-slot vm:other-pointer-type)) + +(defun patch-fdefn (fdefn new-fun) + (setf (kernel:fdefn-function fdefn) new-fun) + (let ((name (kernel:%function-name new-fun))) + (set-fdefn-name fdefn name)) + fdefn) + +(pushnew 'check-function-redefinition ext:*setf-fdefinition-hook*) diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index bed153e..3ba64a0 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -1060,6 +1060,7 @@

(define-info-type function calling-convention symbol nil)

+(define-info-type function lisp::linkage lisp::linkage nil)

); defun function-info-init

commit 22b8ddc2a0f8280d586c8bc3bdadd6f290f1bfa2 Author: Helmut Eller eller.helmut@gmail.com Date: Sat Jun 16 23:46:25 2012 +0200

Add a new fop to find typed entries at load-time. The function of a %type-call is loaded with the new vop.

diff --git a/src/code/load.lisp b/src/code/load.lisp index b5f591d..11a20ec 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -1519,4 +1519,10 @@ code-object))

+(define-fop (fop-typed-entry-point 151) + (let ((type (pop-stack)) + (name (pop-stack))) + (find-typed-entry-point name type))) + + (declaim (maybe-inline read-byte)) diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index ac95c2e..c3b2ed0 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -521,7 +521,12 @@ (dump-push (cdr entry) file)) (:fdefinition (dump-object (cdr entry) file) - (dump-fop 'lisp::fop-fdefinition file)))) + (dump-fop 'lisp::fop-fdefinition file)) + (:typed-entry-point + (destructuring-bind (name ftype) (cdr entry) + (dump-object name file) + (dump-object (type-specifier ftype) file) + (dump-fop 'lisp::fop-typed-entry-point file))))) (null (dump-fop 'lisp::fop-misc-trap file)))))

diff --git a/src/compiler/generic/core.lisp b/src/compiler/generic/core.lisp index bcc29de..459c6bc 100644 --- a/src/compiler/generic/core.lisp +++ b/src/compiler/generic/core.lisp @@ -203,7 +203,13 @@ (cdr const) object)) (:fdefinition (setf (code-header-ref code-obj index) - (lisp::fdefinition-object (cdr const) t)))))))))) + (lisp::fdefinition-object (cdr const) t))) + (:typed-entry-point + (destructuring-bind (name ftype) (cdr const) + (let ((typespec (type-specifier ftype))) + (setf (code-header-ref code-obj index) + (lisp::find-typed-entry-point name typespec))))) + ))))))) (undefined-value))

diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index 9232a1e..8bf1517 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -568,6 +568,14 @@ (annotate-ordinary-continuation value policy))

+ +(defoptimizer (%typed-call ltn-annotate) ((&rest args) node policy) + (let ((fdefn (combination-fun node))) + (annotate-function-continuation fdefn policy t) + (dolist (arg args) + (annotate-ordinary-continuation arg policy)))) + + ;;;; Known call annotation:

;;; OPERAND-RESTRICTION-OK -- Interface

commit c3efc0277e5e4645ee10d82acbf9db1c082c9c3d Author: Helmut Eller eller.helmut@gmail.com Date: Sat Jun 16 23:42:41 2012 +0200

Generate special ir2 for %typed-calls. Define the vop and export it.

diff --git a/src/code/exports.lisp b/src/code/exports.lisp index cb91814..060ad89 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -1759,8 +1759,9 @@ "TN" "TN-OFFSET" "TN-P" "TN-REF" "TN-REF-ACROSS" "TN-REF-LOAD-TN" "TN-REF-NEXT" "TN-REF-NEXT-REF" "TN-REF-P" "TN-REF-TARGET" "TN-REF-TN" "TN-REF-VOP" "TN-REF-WRITE-P" "TN-SC" "TN-VALUE" - "TRACE-TABLE-ENTRY" "TYPE-CHECK-ERROR" - "TYPED-ENTRY-POINT-ALLOCATE-FRAME" "TYPED-CALL-LOCAL" + "TRACE-TABLE-ENTRY" "TYPE-CHECK-ERROR" + "TYPED-CALL-LOCAL" "TYPED-CALL-NAMED" + "TYPED-ENTRY-POINT-ALLOCATE-FRAME" "UNBIND" "UNBIND-TO-HERE" "UNSAFE" "UNWIND" "UWP-ENTRY" "VALUE-CELL-REF" "VALUE-CELL-SET" "VALUES-LIST" diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index e7efcb0..d1aa8b5 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -1768,6 +1768,35 @@ compilation policy") (move-continuation-result node block (list val) (node-cont node))))

+(defun typed-entry-point-continuation-tn (fun ftype) + (declare (type continuation fun) (type function-type ftype)) + (let ((2cont (continuation-info fun))) + (assert (eq (ir2-continuation-kind 2cont) :delayed)) + (let ((name (continuation-function-name fun t))) + (assert name) + (make-load-time-constant-tn :typed-entry-point (list name ftype))))) + +(defoptimizer (%typed-call ir2-convert) ((&rest args) node block) + (let* ((fun (combination-fun node)) + (ftype (continuation-derived-type fun)) + (cont (node-cont node))) + (check-type ftype function-type) + (multiple-value-bind (arg-tns result-tns + fp stack-frame-size + nfp number-stack-frame-size) + (make-typed-call-tns ftype) + (declare (ignore number-stack-frame-size)) + (let ((fdefn-tn (typed-entry-point-continuation-tn fun ftype)) + (cont-tns (loop for arg in args + collect (continuation-tn node block arg)))) + (vop allocate-frame node block nil fp nfp) + (vop* typed-call-named node block + (fp nfp fdefn-tn (reference-tn-list cont-tns nil)) + ((reference-tn-list result-tns t)) + arg-tns stack-frame-size) + (move-continuation-result node block result-tns cont))))) + + ;;; IR2-Convert -- Interface ;;; ;;; Convert the code in a component into VOPs. diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 835ffe8..90d9259 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -1149,6 +1149,46 @@ (inst jmp (make-fixup 'tail-call-variable :assembly-routine))))

+(define-vop (typed-call-named) + (:args (new-fp) + (new-nfp) + (fdefn :scs (descriptor-reg control-stack) + :target eax) + (args :more t :scs (descriptor-reg))) + (:results (results :more t)) + (:save-p t) + (:move-args :local-call) + (:vop-var vop) + (:info arg-locs real-frame-size) + (:ignore new-nfp args arg-locs results) + (:temporary (:sc descriptor-reg :offset eax-offset) + eax) + (:generator 30 + ;; FIXME: allocate the real frame size here. We had to emit + ;; ALLOCATE-FRAME before this vop so that we can use the + ;; (:move-args :local-call) option here. Without the + ;; ALLOCATE-FRAME vop we get a failed assertion. + (inst lea esp-tn (make-ea :dword :base new-fp + :disp (- (* real-frame-size word-bytes)))) + + ;; Move fdefn to eax before switching frames. + (move eax fdefn) + + ;; Write old frame pointer (epb) into new frame. + (storew ebp-tn new-fp (- (1+ ocfp-save-offset))) + + ;; Switch to new frame. + (move ebp-tn new-fp) + + (note-this-location vop :call-site) + + ;; Load address out of fdefn and call it. + (inst call (make-ea :dword :base eax + :disp (- (* fdefn-raw-addr-slot word-bytes) + other-pointer-type))) + + )) + ;;;; Unknown values return:

;;; Return a single-value using the Unknown-Values convention. Specifically,

commit 6b7a5961da54835daeaaee11d9e9c74164c9dd69 Author: Helmut Eller eller.helmut@gmail.com Date: Sat Jun 16 23:38:13 2012 +0200

Update some places that require type/name of XEPs. The functional-entry-function of a XEP may now be a typed entry point but the old code assumed that its the main lambda.

diff --git a/src/compiler/entry.lisp b/src/compiler/entry.lisp index 1164062..8a8c18f 100644 --- a/src/compiler/entry.lisp +++ b/src/compiler/entry.lisp @@ -33,7 +33,7 @@ (let ((2comp (component-info component))) (dolist (fun (component-lambdas component)) (when (or (external-entry-point-p fun) - (getf (lambda-plist fun) :entry-point)) + (typed-entry-point-p fun)) (let ((info (or (leaf-info fun) (setf (leaf-info fun) (make-entry-info))))) (compute-entry-info fun info) @@ -108,16 +108,21 @@ ;;; (defun compute-entry-info (fun info) (declare (type clambda fun) (type entry-info info)) - (let ((bind (lambda-bind fun)) - (internal-fun (functional-entry-function fun))) + (let* ((bind (lambda-bind fun)) + (internal-fun (functional-entry-function fun)) + (internal-fun (cond ((typed-entry-point-p internal-fun) + (functional-entry-function internal-fun)) + (t internal-fun))) + (tep (typed-entry-point-p fun))) (setf (entry-info-closure-p info) (not (null (environment-closure (lambda-environment fun))))) (setf (entry-info-offset info) (gen-label)) (setf (entry-info-name info) (let ((name (leaf-name internal-fun))) - (or name - (component-name (block-component (node-block bind)))))) - (when (policy bind (>= debug 1)) + (cond (tep (list :typed-entry-point name)) + (name) + (t (component-name (block-component (node-block bind))))))) + (when (or (policy bind (>= debug 1)) tep) (setf (entry-info-arguments info) (make-arg-names internal-fun)) (setf (entry-info-type info) (type-specifier (leaf-type internal-fun))))) (undefined-value)) @@ -146,6 +151,9 @@ (case (functional-kind lambda) (:external (let* ((ef (functional-entry-function lambda)) + (ef (cond ((typed-entry-point-p ef) + (functional-entry-function ef)) + (t ef))) (new (make-functional :kind :top-level-xep :info (leaf-info lambda) :name (leaf-name ef) diff --git a/src/compiler/ir1final.lisp b/src/compiler/ir1final.lisp index 3772243..0e924ab 100644 --- a/src/compiler/ir1final.lisp +++ b/src/compiler/ir1final.lisp @@ -62,6 +62,9 @@ ;;; (defun finalize-xep-definition (fun) (let* ((leaf (functional-entry-function fun)) + (leaf (if (typed-entry-point-p leaf) + (functional-entry-function leaf) + leaf)) (name (leaf-name leaf)) (dtype (definition-type leaf))) (setf (leaf-type leaf) dtype) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 0528787..1082202 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1531,7 +1531,10 @@ (defun main-entry (functional) (declare (type functional functional) (values clambda)) (etypecase functional - (clambda functional) + (clambda + (cond ((typed-entry-point-p functional) + (lambda-entry-function functional)) + (t functional))) (optional-dispatch (optional-dispatch-main-entry functional))))

@@ -1568,7 +1571,6 @@ (declare (type functional fun)) (not (null (member (functional-kind fun) '(:external :top-level)))))

- ;;; Continuation-Function-Name -- Interface ;;; ;;; If Cont's only use is a non-notinline global function reference, then

commit 7db4f90521a52676d4aaa244dbc7964c91b68bce Author: Helmut Eller eller.helmut@gmail.com Date: Sat Jun 16 23:31:53 2012 +0200

Add a function typed-entry-point-p to abstract a bit from representation.

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index c39f17e..0528787 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1518,6 +1518,11 @@  ;;;; Functional hackery:

+(defun typed-entry-point-p (fun) + (and (lambda-p fun) + (eq (getf (lambda-plist fun) :entry-point) + :typed))) + ;;; Main-Entry -- Interface ;;; ;;; If Functional is a Lambda, just return it; if it is an

commit d75cd3b8e4f8681f55cd54461d8a8ac79d5e1662 Author: Helmut Eller eller.helmut@gmail.com Date: Sat Jun 16 23:26:58 2012 +0200

In probable-type-check-p, request type checking for the new convention.

With the typed convention the type checks should be performed in the caller (normal :full calls check types in the callee). :simple checks will be performed by he move-arg vops the :hairy cases are done checkgen.

diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index eaa4572..6d4fc6b 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -379,7 +379,12 @@ (let ((kind (basic-combination-kind dest))) (cond ((eq cont (basic-combination-fun dest)) t) ((eq kind :local) t) - ((member kind '(:full :error)) nil) + ((member kind '(:full :error)) + (let ((name (continuation-function-name + (combination-fun dest)))) + (cond ((info function calling-convention name) + t) + (t nil)))) ((function-info-ir2-convert kind) t) (t (dolist (template (function-info-templates kind) nil)

commit 0000513f96308b121cd04329dd99ebd530dd3e2b Author: Helmut Eller eller.helmut@gmail.com Date: Sat Jun 16 23:18:05 2012 +0200

In recognize-known-call, look at the calling-convention.

If basic-combination-kind to the function-finfo of %typed-call. Struct accessors/setters are handled similarily. The problem with this approach is that we can't have transforms/optmizers etc. when the type calling convention is used. Add a function-info attribute to handle that case (not implemented yet).

diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 5229915..cce9f37 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1332,3 +1332,6 @@ (defknown (compiler-warning compiler-note compiler-mumble) (string &rest t) (values) ())

+ +(defknown %typed-call (&rest t) * + (typed-calling-convention)) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 371617a..1ded755 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -948,7 +948,13 @@ (if (consp name) '%slot-setter '%slot-accessor) - name)))) + name))) + (cc (info function calling-convention name)) + (info (ecase cc + ((nil) info) + (:typed (cond ((not info) + (info function info '%typed-call)) + (t (error "nyi"))))))) (if info (values leaf (setf (basic-combination-kind call) info)) (values leaf nil))))))) diff --git a/src/compiler/knownfun.lisp b/src/compiler/knownfun.lisp index 609d3e7..8c16208 100644 --- a/src/compiler/knownfun.lisp +++ b/src/compiler/knownfun.lisp @@ -82,6 +82,9 @@ ;; ;; Safe to stack-allocate function args that are closures. dynamic-extent-closure-safe + ;; + ;; + typed-calling-convention )

(defstruct (function-info

commit 2d6b37b5c53b89e6b31e56d4b6e1a4ae57c9ffa6 Author: Helmut Eller eller.helmut@gmail.com Date: Fri Jun 15 21:59:57 2012 +0200

Boot hack: define calling-convention before compiling compiler.

diff --git a/src/tools/cross-scripts/cross-x86-x86.lisp b/src/tools/cross-scripts/cross-x86-x86.lisp index 6a57fd2..87c2dad 100644 --- a/src/tools/cross-scripts/cross-x86-x86.lisp +++ b/src/tools/cross-scripts/cross-x86-x86.lisp @@ -46,6 +46,12 @@ (export 'vm::fixup-code-object "VM") (export 'vm::sanctify-for-execution "VM")

+;; +(unless (find "CALLING-CONVENTION" + (c::class-info-types (gethash "FUNCTION" c::*info-classes*)) + :key #'c::type-info-name :test #'equal) + (c::define-info-type function c::calling-convention symbol nil)) + (comf "target:code/exports")

(load "target:tools/comcom") @@ -217,3 +223,4 @@ (let ((ht (c::backend-sc-names c::*target-backend*))) (setf (gethash 'old-vm::any-reg ht) (gethash 'vm::any-reg ht))) +

commit 459e3993717bb3cbedb4547d4a5004877003d40b Author: Helmut Eller eller.helmut@gmail.com Date: Fri Jun 15 21:59:08 2012 +0200

Use x86-make-number-stack-pointer-tn instead of make-number-stack-pointer-tn.

diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 151ea2f..835ffe8 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -215,7 +215,7 @@ (cond ((<= (getf state :reg-args) register-arg-count) (let ((n (getf state :reg-args))) (incf (getf state :reg-args)) - (standard-argument-location n))) + (x86-standard-argument-location n))) (t (make-wired-tn (ptype 't) control-stack-sc-number @@ -244,10 +244,10 @@ collect (arg-tn type arg-state)) (loop for type in rtypes collect (ret-tn type ret-state)) - (make-stack-pointer-tn) + (x86-make-stack-pointer-tn) (max (getf arg-state :frame-size) (getf ret-state :frame-size)) - (make-number-stack-pointer-tn) + (x86-make-number-stack-pointer-tn) 0))))

commit 2b0a11e7fce8dd7e0204c7ad309c746860ee24be Author: Helmut Eller eller.helmut@gmail.com Date: Fri Jun 15 21:28:28 2012 +0200

Compile target:code/exports before comcom. Apparently needed now that export no longer acts at compile time.

diff --git a/src/tools/cross-scripts/cross-x86-x86.lisp b/src/tools/cross-scripts/cross-x86-x86.lisp index aa4d84d..6a57fd2 100644 --- a/src/tools/cross-scripts/cross-x86-x86.lisp +++ b/src/tools/cross-scripts/cross-x86-x86.lisp @@ -46,6 +46,8 @@ (export 'vm::fixup-code-object "VM") (export 'vm::sanctify-for-execution "VM")

+(comf "target:code/exports") + (load "target:tools/comcom")

;;; Load the new backend.

commit 4983d20da4badfe2de5266bfbe580ac655ca7955 Author: Helmut Eller eller.helmut@gmail.com Date: Fri Jun 15 20:28:43 2012 +0200

Remove some random (load "target:code/exports").

diff --git a/Makefile b/Makefile index d409908..808ba2a 100644 --- a/Makefile +++ b/Makefile @@ -68,7 +68,6 @@ XSETUP=' \ (intl::install) \ (setf (ext:search-list "target:") \ (quote ("$(1)/" "src/"))) \ -(load "target:code/exports") \ (load "target:tools/setup" :if-source-newer :load-source) \ (comf "target:tools/setup" :load t) \ (setq *gc-verbose* nil *interactive* nil) \ @@ -169,13 +168,12 @@ xcompiler: $(CROSSCORE)

$(BUILDDIR)/xcompiler/cross-%.core: $(MAKE) sanity - rm -rf $(XCOMPILERDIR) # yes, sucks, but that's the way it is + rm -rf $(XCOMPILERDIR) mkdir -vp $(BUILDDIR) if [ ! -e $(BUILDDIR)/src ] ; then \ ln -s $(TOPDIR)/src $(BUILDDIR)/src ; \ fi $(BINDIR)/create-target.sh $(XCOMPILERDIR) - mkdir -vp $(XCOMPILERDIR)/compiler/jvm cp -v $(TOOLSDIR)/cross-scripts/$(subst .core,.lisp,$(notdir $@)) \ $(XCOMPILERDIR)/cross.lisp $(BOOTCMUCL) -noinit -nositeinit \ @@ -183,7 +181,6 @@ $(BUILDDIR)/xcompiler/cross-%.core: -eval '(setf lisp::*enable-package-locked-errors* nil)' \ -eval '(intl::install)' \ -eval '$(call SET_TARGET_SEARCH_LIST, "$(XCOMPILERDIR)/")' \ --eval '(load "target:code/exports")' \ -eval '(load "target:tools/setup" :if-source-newer :load-source)' \ -eval '(comf "target:tools/setup" :load t)' \ -eval '(setq *gc-verbose* nil *interactive* nil)' \

commit 0c334764a1812bbc71c30ea964f8cb86360b7729 Author: Helmut Eller eller.helmut@gmail.com Date: Fri Jun 15 20:25:51 2012 +0200

Add a new info type: calling-convention Make defuns with a calling-convention declaration known the info db.

diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index ae7b565..bed153e 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -1058,6 +1058,8 @@

(define-info-type function definition t nil)

+(define-info-type function calling-convention symbol nil) +

); defun function-info-init

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 2c70f62..f4ce61d 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -3990,7 +3990,14 @@ (lambda (second def)) (*current-path* (revert-source-path 'defun)) (expansion (unless (eq (info function inlinep name) :notinline) - (inline-syntactic-closure-lambda lambda)))) + (inline-syntactic-closure-lambda lambda))) + (decls (nth-value 1 (system:parse-body (cddr lambda) + *lexical-environment* t))) + (convention (find-declaration 'calling-convention decls 1 0))) + (cond (convention + (setf (info function calling-convention name) convention)) + (t + (clear-info function calling-convention name))) ;; ;; If not in a simple environment or :notinline, then discard any forward ;; references to this function.

commit 8eb8276f55954d01f81fc1b5b88db564b934de6c Author: Helmut Eller eller.helmut@gmail.com Date: Fri Jun 15 20:23:39 2012 +0200

Export new vops from VM package.

diff --git a/src/code/exports.lisp b/src/code/exports.lisp index a46d5bb..cb91814 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -1759,7 +1759,9 @@ "TN" "TN-OFFSET" "TN-P" "TN-REF" "TN-REF-ACROSS" "TN-REF-LOAD-TN" "TN-REF-NEXT" "TN-REF-NEXT-REF" "TN-REF-P" "TN-REF-TARGET" "TN-REF-TN" "TN-REF-VOP" "TN-REF-WRITE-P" "TN-SC" "TN-VALUE" - "TRACE-TABLE-ENTRY" "TYPE-CHECK-ERROR" "UNBIND" "UNBIND-TO-HERE" + "TRACE-TABLE-ENTRY" "TYPE-CHECK-ERROR" + "TYPED-ENTRY-POINT-ALLOCATE-FRAME" "TYPED-CALL-LOCAL" + "UNBIND" "UNBIND-TO-HERE" "UNSAFE" "UNWIND" "UWP-ENTRY" "VALUE-CELL-REF" "VALUE-CELL-SET" "VALUES-LIST" "VERIFY-ARGUMENT-COUNT" "WRITE-PACKED-BIT-VECTOR"

commit 7ce2afa859e8429837a4c69564e822762ff461fa Author: Helmut Eller eller.helmut@gmail.com Date: Fri Jun 15 20:22:10 2012 +0200

Create actual entry in code object for typed entry. Also make it possible to call the typed entry from XEP.

diff --git a/src/compiler/entry.lisp b/src/compiler/entry.lisp index f5ec8ba..1164062 100644 --- a/src/compiler/entry.lisp +++ b/src/compiler/entry.lisp @@ -32,11 +32,14 @@ (defun entry-analyze (component) (let ((2comp (component-info component))) (dolist (fun (component-lambdas component)) - (when (external-entry-point-p fun) + (when (or (external-entry-point-p fun) + (getf (lambda-plist fun) :entry-point)) (let ((info (or (leaf-info fun) (setf (leaf-info fun) (make-entry-info))))) (compute-entry-info fun info) - (push info (ir2-component-entries 2comp)))))) + (push info (ir2-component-entries 2comp)) + (when (getf (lambda-plist fun) :entry-point) + (setf (getf (lambda-plist fun) :code-start) (gen-label)))))))

(select-component-format component) (undefined-value)) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 6c2dc48..e7efcb0 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -903,6 +903,25 @@ compilation policy") (move-continuation-result node block locs cont))))) (undefined-value))

+(defun ir2-convert-local-typed-call (node block fun cont) + (declare (type node node) (type ir2-block block) (type clambda fun) + (type continuation cont)) + (let ((ftype (the function-type (lambda-type fun))) + (args (basic-combination-args node)) + (start (getf (lambda-plist fun) :code-start))) + (multiple-value-bind (arg-tns result-tns + fp stack-frame-size + nfp number-stack-frame-size) + (make-typed-call-tns ftype) + (declare (ignore number-stack-frame-size)) + (let ((cont-tns (loop for arg in args + collect (continuation-tn node block arg)))) + (vop allocate-frame node block nil fp nfp) + (vop* typed-call-local node block + (fp nfp (reference-tn-list cont-tns nil)) + ((reference-tn-list result-tns t)) + arg-tns stack-frame-size start) + (move-continuation-result node block result-tns cont)))))

;;; IR2-Convert-Local-Call -- Internal ;;; @@ -931,8 +950,13 @@ compilation policy") (:unknown (ir2-convert-local-unknown-call node block fun cont start)) (:fixed - (ir2-convert-local-known-call node block fun returns - cont start))))))) + (ecase (getf (lambda-plist fun) :entry-point) + ((nil) + (ir2-convert-local-known-call node block fun returns + cont start)) + (:typed + (assert (external-entry-point-p (node-home-lambda node))) + (ir2-convert-local-typed-call node block fun cont))))))))) (undefined-value))

@@ -1178,6 +1202,18 @@ compilation policy")

(undefined-value))

+;; arguments are wired to specific locations in gtn so we should have +;; to move them here. +(defun init-typed-entry-point-environment (node block fun) + (declare (type bind node) (type ir2-block block) (type clambda fun)) + (let ((start-label (entry-info-offset (leaf-info fun))) + (code-label (getf (lambda-plist fun) :code-start)) + (env (environment-info (node-environment node)))) + (vop typed-entry-point-allocate-frame node block + start-label code-label) + (vop setup-environment node block start-label) + (emit-move node block (make-old-fp-passing-location t) + (ir2-environment-old-fp env))))

;;; IR2-Convert-Bind -- Internal ;;; @@ -1202,6 +1238,9 @@ compilation policy") (vop count-me node block *dynamic-counts-tn* (block-number (ir2-block-block block)))))

+ (when (getf (lambda-plist fun) :entry-point) + (init-typed-entry-point-environment node block fun)) + (emit-move node block (ir2-environment-return-pc-pass env) (ir2-environment-return-pc env))

diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index a5e9996..151ea2f 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -203,7 +203,7 @@ (double-float-arg (state) (cond ((<= (getf state :xmms-reg) xmm7-offset) (make-wired-tn (ptype 'double-float) - double-reg-sc-number + double-reg-sc-number (prog1 (getf state :xmms-reg) (incf (getf state :xmms-reg))))) (t @@ -216,7 +216,7 @@ (let ((n (getf state :reg-args))) (incf (getf state :reg-args)) (standard-argument-location n))) - (t + (t (make-wired-tn (ptype 't) control-stack-sc-number (prog1 (getf state :frame-size) @@ -230,7 +230,7 @@ (t (boxed-arg state)))) (ret-tn (type state) (let ((tn (arg-tn type state))) - (assert (member (sc-name (tn-sc tn)) + (assert (member (sc-name (tn-sc tn)) '(double-reg descriptor-reg))) tn))) (let* ((arg-state (list :frame-size 2 :xmms-reg xmm4-offset :reg-args 0)) @@ -299,6 +299,34 @@

(trace-table-entry trace-table-normal)))

+(define-vop (typed-entry-point-allocate-frame) + (:info start-label code-label) + (:vop-var vop) + (:generator 1 + ;; Make sure the function is aligned (using NOPs), and drop a + ;; label pointing to this function header. + (align lowtag-bits #x90) + (trace-table-entry trace-table-function-prologue) + (emit-label start-label) + ;; Skip space for the function header. + (inst function-header-word) + (dotimes (i (1- vm:function-code-offset)) + (inst dword 0)) + + ;; The start of the actual code. + (emit-label code-label) + + ;; Save the return-pc. + (popw ebp-tn (- (1+ return-pc-save-offset))) + + ;; The args fit within the frame so just allocate the frame. + (inst lea esp-tn + (make-ea :dword :base ebp-tn + :disp (- (* vm:word-bytes + (sb-allocated-size 'stack))))) + + (trace-table-entry trace-table-normal))) + ;;; This is emitted directly before either a known-call-local, call-local, ;;; or a multiple-call-local. All it does is allocate stack space for the ;;; callee (who has the same size stack as us). @@ -732,6 +760,38 @@ RETURN (note-this-location vop :known-return) (trace-table-entry trace-table-normal))) + + +(define-vop (typed-call-local) + (:args (new-fp) + (new-nfp) + (args :more t)) + (:results (results :more t)) + (:save-p t) + (:move-args :local-call) + (:vop-var vop) + (:info arg-locs real-frame-size target) + (:ignore new-nfp args arg-locs results) + (:generator 30 + ;; FIXME: allocate the real frame size here. We had to emit + ;; ALLOCATE-FRAME before this vop so that we can use the + ;; (:move-args :local-call) option here. Without the + ;; ALLOCATE-FRAME vop we get a failed assertion. + (inst lea esp-tn (make-ea :dword :base new-fp + :disp (- (* real-frame-size word-bytes)))) + + ;; Write old frame pointer (epb) into new frame. + (storew ebp-tn new-fp (- (1+ ocfp-save-offset))) + + ;; Switch to new frame. + (move ebp-tn new-fp) + + (note-this-location vop :call-site) + + (inst call target) + + )) +  ;;; Return from known values call. We receive the return locations as ;;; arguments to terminate their lifetimes in the returning function. We

commit 3a28ef3ac0db9745535a18659530b8ba060a2636 Author: Helmut Eller eller.helmut@gmail.com Date: Fri Jun 15 20:10:06 2012 +0200

Assign lambda vars to the TNs as indicated by make-typed-call-tns. For lambdas with the (entry-point :typed) declaration we wire the arguments to the locations as dictated by the typed convention.

diff --git a/src/compiler/gtn.lisp b/src/compiler/gtn.lisp index 99d3e13..39d9b17 100644 --- a/src/compiler/gtn.lisp +++ b/src/compiler/gtn.lisp @@ -50,6 +50,15 @@ ;;; (defun assign-lambda-var-tns (fun let-p) (declare (type clambda fun)) + (ecase (getf (lambda-plist fun) :entry-point) + ((nil) + (assign-normal-lambda-var-tns fun let-p)) + (:typed + (assign-typed-lambda-var-tns fun))) + (undefined-value)) + +(defun assign-normal-lambda-var-tns (fun let-p) + (declare (type clambda fun)) (dolist (var (lambda-vars fun)) (when (leaf-refs var) (let* ((type (if (lambda-var-indirect var) @@ -64,9 +73,16 @@ (environment-debug-live-tn temp (lambda-environment fun))))) (setf (tn-leaf res) var) - (setf (leaf-info var) res)))) - (undefined-value)) + (setf (leaf-info var) res)))))

+(defun assign-typed-lambda-var-tns (fun) + (declare (type clambda fun)) + (let ((ftype (lambda-type fun))) + (loop for var in (lambda-vars fun) + for tn in (make-typed-call-tns ftype) + do (when (leaf-refs var) + (setf (tn-leaf tn) var) + (setf (leaf-info var) tn)))))

;;; Assign-IR2-Environment -- Internal ;;; @@ -95,7 +111,7 @@ (make-old-fp-save-location env)) (setf (ir2-environment-return-pc res) (make-return-pc-save-location env))))) - + (undefined-value))

@@ -188,6 +204,21 @@ ;;; reason. Otherwise we allocate passing locations for a fixed number of ;;; values. ;;; +(defun choose-return-locations (fun) + (declare (type clambda fun)) + (ecase (getf (lambda-plist fun) :entry-point) + ((nil) + (let* ((tails (lambda-tail-set fun)) + (ep (find-if (lambda (fun) + (getf (lambda-plist fun) :entry-point)) + (tail-set-functions tails)))) + (cond (ep + (return-info-for-typed-convention ep)) + (t + (return-info-for-set tails))))) + (:typed + (return-info-for-typed-convention fun)))) + (defun return-info-for-set (tails) (declare (type tail-set tails)) (multiple-value-bind (types count) @@ -204,6 +235,14 @@ :types ptypes :locations (mapcar #'make-normal-tn ptypes))))))

+(defun return-info-for-typed-convention (fun) + (declare (type clambda fun)) + (let* ((ftype (lambda-type fun)) + (tns (nth-value 1 (make-typed-call-tns ftype)))) + (make-return-info :kind :fixed + :count (length tns) + :types (mapcar #'tn-primitive-type tns) + :locations tns)))

;;; Assign-Return-Locations -- Internal ;;; @@ -217,7 +256,7 @@ (let* ((tails (lambda-tail-set fun)) (returns (or (tail-set-info tails) (setf (tail-set-info tails) - (return-info-for-set tails)))) + (choose-return-locations fun)))) (return (lambda-return fun))) (when (and return (not (eq (return-info-kind returns) :unknown)) @@ -226,7 +265,6 @@ (setf (node-tail-p use) nil)))) (undefined-value))

- ;;; Assign-IR2-NLX-Info -- Internal ;;; ;;; Make an IR2-NLX-Info structure for each NLX entry point recorded. We

commit 3a0e00cc698c7e4f70e90afb218b4db8413d5953 Author: Helmut Eller eller.helmut@gmail.com Date: Fri Jun 15 20:03:30 2012 +0200

Create special entry point if indicated. If a lambda has a (calling-convention :typed) declartion we create a the special entry point.

diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 9d5a54d..6882f92 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -143,17 +143,31 @@ (declare (type functional fun)) (etypecase fun (clambda - (let ((nargs (length (lambda-vars fun))) - (n-supplied (gensym))) - (collect ((temps)) - (dotimes (i nargs) - (temps (gensym))) - `(lambda (,n-supplied ,@(temps)) - (declare (type index ,n-supplied)) - ,(if (policy nil (zerop safety)) - `(declare (ignore ,n-supplied)) - `(%verify-argument-count ,n-supplied ,nargs)) - (%funcall ,fun ,@(temps)))))) + (let* ((nargs (length (lambda-vars fun))) + (n-supplied (gensym)) + (temps (loop repeat nargs collect (gensym))) + (fun (ecase (getf (lambda-plist fun) :calling-convention) + ((nil) fun) + (:typed + (let ((fun2 (ir1-convert-lambda + `(lambda ,temps + (declare (entry-point :typed)) + ,@(loop for tmp in temps + for var in (lambda-vars fun) + collect + `(declare (type + ,(type-specifier + (lambda-var-type var)) + ,tmp))) + (%funcall ,fun . ,temps))))) + (setf (lambda-entry-function fun) fun2) + fun2))))) + `(lambda (,n-supplied . ,temps) + (declare (type index ,n-supplied)) + ,(if (policy nil (zerop safety)) + `(declare (ignore ,n-supplied)) + `(%verify-argument-count ,n-supplied ,nargs)) + (%funcall ,fun . ,temps)))) (optional-dispatch (let* ((min (optional-dispatch-min-args fun)) (max (optional-dispatch-max-args fun)) @@ -208,8 +222,14 @@ (res (ir1-convert-lambda (make-xep-lambda fun)))) (setf (functional-kind res) :external) (setf (leaf-ever-used res) t) - (setf (functional-entry-function res) fun) - (setf (functional-entry-function fun) res) + (cond ((functional-entry-function fun) + (let ((ep (functional-entry-function fun))) + (setf (functional-entry-function ep) fun) + (setf (functional-entry-function fun) ep) + (setf (functional-entry-function res) ep))) + (t + (setf (functional-entry-function res) fun) + (setf (functional-entry-function fun) res))) (setf (component-reanalyze *current-component*) t) (setf (component-reoptimize *current-component*) t) (etypecase fun

commit 505bdffd1297bd43509d8b234f77e9782cd57d12 Author: Helmut Eller eller.helmut@gmail.com Date: Fri Jun 15 19:58:32 2012 +0200

Add a new vm-support-routine: make-typed-call-tns This defines register/representation to use for a given function type.

diff --git a/src/compiler/backend.lisp b/src/compiler/backend.lisp index a8b063e..8f9f711 100644 --- a/src/compiler/backend.lisp +++ b/src/compiler/backend.lisp @@ -96,7 +96,11 @@

;; For use with scheduler. emit-nop - location-number) + location-number + + make-typed-call-tns + +)

(defprinter vm-support-routines)

diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 63104de..a5e9996 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -187,6 +187,70 @@ (undefined-value))

+;; make-typed-call-tns chooses the representation for a function type. +;; This is similar to c::make-call-out-tns and should probably also be +;; a vm-support-routine. +;; +;; The current convention passes double-floats unboxed and all other +;; types remain boxed. Registers XMM4-XMM7 are used for the first 4 +;; double arguments. Boxed values are passed in standard locations. +;; +;; Returning values on the stack is currenlty not implemented, so all +;; return values must fit in registers. +(def-vm-support-routine make-typed-call-tns (ftype) + (declare (type function-type ftype)) + (labels ((ptype (name) (primitive-type-or-lose name *backend*)) + (double-float-arg (state) + (cond ((<= (getf state :xmms-reg) xmm7-offset) + (make-wired-tn (ptype 'double-float) + double-reg-sc-number + (prog1 (getf state :xmms-reg) + (incf (getf state :xmms-reg))))) + (t + (make-wired-tn (ptype 'double-float) + double-stack-sc-number + (prog1 (getf state :frame-size) + (incf (getf state :frame-size) 2)))))) + (boxed-arg (state) + (cond ((<= (getf state :reg-args) register-arg-count) + (let ((n (getf state :reg-args))) + (incf (getf state :reg-args)) + (standard-argument-location n))) + (t + (make-wired-tn (ptype 't) + control-stack-sc-number + (prog1 (getf state :frame-size) + (incf (getf state :frame-size) 1)))))) + (double-float-type-p (type) + (and (numeric-type-p type) + (eq (numeric-type-class type) 'float) + (eq (numeric-type-format type) 'double-float))) + (arg-tn (type state) + (cond ((double-float-type-p type) (double-float-arg state)) + (t (boxed-arg state)))) + (ret-tn (type state) + (let ((tn (arg-tn type state))) + (assert (member (sc-name (tn-sc tn)) + '(double-reg descriptor-reg))) + tn))) + (let* ((arg-state (list :frame-size 2 :xmms-reg xmm4-offset :reg-args 0)) + (ret-state (list :frame-size 2 :xmms-reg xmm4-offset :reg-args 0)) + (returns (function-type-returns ftype)) + (rtypes (typecase returns + (values-type (values-type-required returns)) + (t (list returns))))) + (values + (loop for type in (function-type-required ftype) + collect (arg-tn type arg-state)) + (loop for type in rtypes + collect (ret-tn type ret-state)) + (make-stack-pointer-tn) + (max (getf arg-state :frame-size) + (getf ret-state :frame-size)) + (make-number-stack-pointer-tn) + 0)))) + + ;;;; Frame hackery:

;;; Used for setting up the Old-FP in local call.

commit 24495066a479bc6a889b4402e2f78d7cb09e096c Author: Helmut Eller eller.helmut@gmail.com Date: Fri Jun 15 19:51:22 2012 +0200

Add declarations: calling-convention and entry-point. We use two new declarations for lambda to choose the calling convention.

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 81c7d74..2c70f62 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -142,6 +142,19 @@ (member (car y) '(flet labels)) (equal x (cadr y)))))

+(declaim (declaration calling-convention)) +(declaim (declaration entry-point)) + +(defun find-declaration (name declarations &optional argcount nth) + (loop for (nil . decls) in declarations do + (loop for d in decls + for (decl-name . values) = d + do (when (eq decl-name name) + (when argcount + (assert (= (length values) argcount))) + (return-from find-declaration + (cond (nth (nth nth values)) + (t d)))))))

;;; *ALLOW-DEBUG-CATCH-TAG* controls whether we should allow the ;;; insertion a (CATCH ...) around code to allow the debugger @@ -1570,6 +1583,9 @@ (process-declarations (append context-decls decls) (append aux-vars vars) nil cont)) + (calling-convention (find-declaration 'calling-convention decls + 1 0)) + (entry-point (find-declaration 'entry-point decls 1 0)) (res (if (or (find-if #'lambda-var-arg-info vars) keyp) (ir1-convert-hairy-lambda new-body vars keyp allow-other-keys @@ -1590,6 +1606,11 @@ (and decl (eq 'declare (first decl)) (cons 'pcl::method (cadadr decl)))))) + (when calling-convention + (setf (getf (lambda-plist res) :calling-convention) + calling-convention)) + (when entry-point + (setf (getf (lambda-plist res) :entry-point) entry-point)) res))))

commit c10c63de861542c04cdb378274231890f3118e9e Author: Helmut Eller eller.helmut@gmail.com Date: Mon Jun 11 22:34:57 2012 +0200

Add my Makefile.

diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..d409908 --- /dev/null +++ b/Makefile @@ -0,0 +1,388 @@ +# Makefile to build cmucl + +TOPDIR := $(PWD) +TOOLSDIR := $(TOPDIR)/src/tools +BINDIR := $(TOPDIR)/bin +BUILDDIR := $(TOPDIR)/build +BOOTCMUCL := cmucl +XHOST := x86 +XTARGET := x86 +BOOTFILE := + +help: + @echo -e "\ +all -- world (= xcompiler+genesis+runtime+compiler+pcl)\n\ +help -- Print out help information\n\ +help-vars -- Information about make variables\n\ +help-other -- Information about rarely needed targets\n\ +world -- Create core file and C runtime\n\ +xcompiler -- Build a core file with cross-compiler loaded\n\ +genesis -- Cross-dump initial image (no compiler, no pcl) \n\ +runtime -- Build C runtime\n\ +compiler -- Build core file with compiler loaded\n\ +pcl -- Build core file with compiler+pcl loaded\n\ +stage2 -- Compile world again using compiler (no cross-compiler)\n\ +clean -- Remove build directory\ +" + +help-vars: + @echo -e "\ +TOPDIR directory containing src directory ($(TOPDIR))\n\ +TOOLSDIR directory with build scripts ($(TOOLSDIR))\n\ +BUILDDIR build directory ($(BUILDDIR))\n\ +BOOTCMUCL compiler used for bootstrap ($(BOOTCMUCL))\n\ +XHOST host system ($(XHOST))\n\ +XTARGET target system ($(XTARGET))\n\ +BOOTFILE file for bootstrap hacks (default: none)\ +" + +help-other: + @echo -e "\ +xcompile-world -- cross-compile library \n\ +xcompile-compiler -- cross-compile compiler \n\ +xdump-world -- cold-load library and cross-dump (genesis)\n\ +clean-world -- remove the build/world directory\n\ +sanity-clean -- remove fasl files in source directory\n\ +run-xcompiler -- open a REPL with the cross-compiler\ +" + +all: world + +XCOMPILERDIR := $(BUILDDIR)/xcompiler +KERNELDIR := $(BUILDDIR)/world +COMPILERDIR := $(BUILDDIR)/compiler +PCLDIR := $(BUILDDIR)/pcl +STAGE2DIR := $(BUILDDIR)/stage2 + +CROSSCORE := $(XCOMPILERDIR)/cross-$(XHOST)-$(XTARGET).core +KERNELCORE := $(KERNELDIR)/lisp/kernel.core +RUNTIME := $(KERNELDIR)/lisp/lisp +COMPILERCORE := $(COMPILERDIR)/lisp/compiler.core +PCLCORE := $(PCLDIR)/lisp/pcl.core +LISPCORE := $(KERNELDIR)/lisp/lisp.core +KERNELCORE2 := $(STAGE2DIR)/lisp/kernel.core +RUNTIME2 := $(STAGE2DIR)/lisp/lisp +LISPCORE2 := $(STAGE2DIR)/lisp/lisp.core + +XSETUP=' \ +(intl::install) \ +(setf (ext:search-list "target:") \ + (quote ("$(1)/" "src/"))) \ +(load "target:code/exports") \ +(load "target:tools/setup" :if-source-newer :load-source) \ +(comf "target:tools/setup" :load t) \ +(setq *gc-verbose* nil *interactive* nil) \ +' + +SETUP2=' \ +(intl::install) \ +(setq *compile-print* t) \ +(setq *load-verbose* t) \ +(load "target:setenv") \ +(pushnew :no-clx *features*) \ +(pushnew :no-clm *features*) \ +(pushnew :no-hemlock *features*) \ +(load "target:code/exports") \ +(load "target:tools/setup" :if-source-newer :load-source) \ +(comf "target:tools/setup" :load t) \ +(setq *gc-verbose* nil *interactive* nil) \ +' + +LOAD_BOOTFILE=' \ +(let ((bootfile "$(BOOTFILE)")) \ + (unless (equal bootfile "") \ + (load bootfile))) \ +' + +SET_TARGET_SEARCH_LIST=(setf (ext:search-list "target:") (list $(1) "src/")) + +XSETENV=' \ +$(call SET_TARGET_SEARCH_LIST,$(1)) \ +(pushnew :bootstrap *features*) \ +(load "target:setenv") \ +(pushnew :no-pcl *features*) \ +(pushnew :no-clx *features*) \ +(pushnew :no-clm *features*) \ +(pushnew :no-hemlock *features*) \ +' + +#(load "target:tools/comcom") \ +#(comf "target:compiler/generic/new-genesis") \ + +LOAD_WORLD=' \ +(in-package :cl-user) \ +$(call SET_TARGET_SEARCH_LIST, "$(KERNELDIR)/") \ +(load "target:setenv") \ +(pushnew :no-compiler *features*) \ +(pushnew :no-clx *features*) \ +(pushnew :no-clm *features*) \ +(pushnew :no-hemlock *features*) \ +(pushnew :no-pcl *features*) \ +(load "target:tools/worldload") \ +' + +#(setf (ext:search-list "target:") \ +# (list "$(COMPILERDIR)/" "$(KERNELDIR)/" "src/")) \ + +LOAD_COMPILER=' \ +(in-package :cl-user) \ +$(call SET_TARGET_SEARCH_LIST,"$(COMPILERDIR)/" "$(KERNELDIR)/") \ +(load "target:setenv") \ +(pushnew :no-clx *features*) \ +(pushnew :no-clm *features*) \ +(pushnew :no-hemlock *features*) \ +(pushnew :no-pcl *features*) \ +(load "target:tools/worldload") \ +' + +COMPILE_PCL=' \ +(load "target:code/exports") \ +(pushnew :bootstrap *features*) \ +(load "target:setenv") \ +(pushnew :no-pcl *features*) \ +(pushnew :no-clx *features*) \ +(pushnew :no-clm *features*) \ +(load "target:tools/pclcom") \ +' + +LOAD_PCL=' \ +(in-package :cl-user) \ +$(call SET_TARGET_SEARCH_LIST,"$(PCLDIR)/" "$(COMPILERDIR)/" "$(KERNELDIR)/") \ +(load "target:setenv") \ +(pushnew :no-clx *features*) \ +(pushnew :no-clm *features*) \ +(pushnew :no-hemlock *features*) \ +(load "target:tools/worldload") \ +' + +LOAD_PCL2=' \ +(in-package :cl-user) \ +$(call SET_TARGET_SEARCH_LIST,"$(STAGE2DIR)/") \ +(load "target:setenv") \ +(pushnew :no-clx *features*) \ +(pushnew :no-clm *features*) \ +(pushnew :no-hemlock *features*) \ +(load "target:tools/worldload") \ +' + +xcompiler: $(CROSSCORE) + +$(BUILDDIR)/xcompiler/cross-%.core: + $(MAKE) sanity + rm -rf $(XCOMPILERDIR) # yes, sucks, but that's the way it is + mkdir -vp $(BUILDDIR) + if [ ! -e $(BUILDDIR)/src ] ; then \ + ln -s $(TOPDIR)/src $(BUILDDIR)/src ; \ + fi + $(BINDIR)/create-target.sh $(XCOMPILERDIR) + mkdir -vp $(XCOMPILERDIR)/compiler/jvm + cp -v $(TOOLSDIR)/cross-scripts/$(subst .core,.lisp,$(notdir $@)) \ + $(XCOMPILERDIR)/cross.lisp + $(BOOTCMUCL) -noinit -nositeinit \ +-eval '(in-package :cl-user)' \ +-eval '(setf lisp::*enable-package-locked-errors* nil)' \ +-eval '(intl::install)' \ +-eval '$(call SET_TARGET_SEARCH_LIST, "$(XCOMPILERDIR)/")' \ +-eval '(load "target:code/exports")' \ +-eval '(load "target:tools/setup" :if-source-newer :load-source)' \ +-eval '(comf "target:tools/setup" :load t)' \ +-eval '(setq *gc-verbose* nil *interactive* nil)' \ +-eval '(load "$(XCOMPILERDIR)/cross.lisp")' \ +-eval '(remf ext::*herald-items* :python)' \ +-eval '(ext:save-lisp "$@" :purify nil)' \ +-eval '(ext:quit)' +# Strangeness 1: the -batch command line option breaks the build! +# Strangeness 2: if :purify is t, the compiler in the core file doesn't work + +xlisp: xcompiler + $(BOOTCMUCL) -core $(CROSSCORE) + +xcompile-world: $(KERNELDIR)/world.snapshot + +$(KERNELDIR)/world.snapshot: $(CROSSCORE) + $(MAKE) sanity + $(MAKE) clean-world + $(BINDIR)/create-target.sh $(KERNELDIR) + $(BOOTCMUCL) \ + -core $(CROSSCORE) \ + -noinit -nositeinit \ + -eval $(call XSETENV, "$(KERNELDIR)/") \ + -eval $(LOAD_BOOTFILE) \ + -eval '(load "target:tools/worldcom")' \ + -eval '(ext:save-lisp "$@" :purify nil)' \ + -eval '(ext:quit)' + +xcompile-compiler: $(COMPILERDIR)/compiler.snapshot + +$(COMPILERDIR)/compiler.snapshot: $(KERNELDIR)/world.snapshot + $(MAKE) sanity + $(MAKE) clean-compiler + $(BINDIR)/create-target.sh $(COMPILERDIR) + $(BOOTCMUCL) \ + -core $< \ + -noinit -nositeinit \ + -eval $(call XSETENV, "$(COMPILERDIR)/") \ + -eval $(LOAD_BOOTFILE) \ + -eval '(load "target:tools/comcom")' \ + -eval '(ext:save-lisp "$@" :purify nil)' \ + -eval '(ext:quit)' + +run-xcompiler: xcompiler + $(MAKE) sanity + $(BOOTCMUCL) \ + -core $(CROSSCORE) \ + -noinit \ + -eval $(call XSETENV, "$(KERNELDIR)/") \ + -eval $(SETUP_CROSS_COMPILER) \ + -eval $(LOAD_BOOTFILE) + +MOVECORE=cd $(1) &&\ + mv lisp.core $(2) \ + || mv lisp-sse2.core $(2) \ + || mv lisp-x87.core $(2) + +genesis: $(KERNELCORE) + +#$(CROSSCORE) +# $(MAKE) xcompile-world +# $(MAKE) xdump-world +# -eval '(load "target:tools/comcom")' \ +# -eval '(comf "target:compiler/generic/new-genesis")' \ + +$(KERNELCORE): $(KERNELDIR)/world.snapshot + $(BOOTCMUCL) \ + -core $(CROSSCORE) \ + -noinit \ + -eval $(call XSETENV, "$(KERNELDIR)/") \ + -eval '(load "target:tools/worldbuild")' \ + -eval '(quit)' + +compiler: $(COMPILERCORE) + +$(COMPILERCORE): $(KERNELCORE) $(RUNTIME) $(COMPILERDIR)/compiler.snapshot + echo $(LOAD_COMPILER) | $(RUNTIME) -core $(KERNELCORE) + $(call MOVECORE,$(COMPILERDIR)/lisp,$@) + +compile-pcl: $(PCLDIR)/pcl.stamp + +$(PCLDIR)/pcl.stamp: $(COMPILERCORE) + $(MAKE) sanity + $(MAKE) clean-pcl + $(BINDIR)/create-target.sh $(PCLDIR) + $(RUNTIME) \ + -core $(COMPILERCORE) \ + -noinit -nositeinit \ + -eval '$(call SET_TARGET_SEARCH_LIST,"$(PCLDIR)/")' \ + -eval $(SETUP2) \ + -eval $(COMPILE_PCL) \ + -eval '(ext:quit)' + touch $@ + +pcl: $(PCLCORE) + +$(PCLCORE): $(PCLDIR)/pcl.stamp + echo $(LOAD_PCL) | $(RUNTIME) -core $(KERNELCORE) + $(call MOVECORE,$(PCLDIR)/lisp,$@) + +runtime: $(RUNTIME) + +$(RUNTIME): $(KERNELDIR)/lisp ; + +$(KERNELDIR)/lisp: $(KERNELCORE) + $(MAKE) -C $(KERNELDIR)/lisp + +.PHONY: $(KERNELDIR)/lisp + +world: $(LISPCORE) + +$(LISPCORE): $(PCLCORE) + cp $< $@ + +compile-world2: $(KERNELCORE2) + +$(KERNELCORE2): $(COMPILERCORE) + $(MAKE) sanity + $(MAKE) clean-stage2 + $(BINDIR)/create-target.sh $(STAGE2DIR) + $(RUNTIME) \ + -core $(COMPILERCORE) \ + -noinit \ +-eval '(in-package :cl-user)' \ +-eval '(intl::install)' \ +-eval '$(call SET_TARGET_SEARCH_LIST, "$(STAGE2DIR)/")' \ +-eval '(load "target:setenv")' \ +-eval '(pushnew :no-clx *features*)' \ +-eval '(pushnew :no-clm *features*)' \ +-eval '(pushnew :no-hemlock *features*)' \ +-eval '(load "target:code/exports")' \ +-eval '(load "target:tools/setup" :if-source-newer :load-source)' \ +-eval '(comf "target:tools/setup" :load t)' \ +-eval '(setq *gc-verbose* nil *interactive* nil)' \ +-eval '(load "target:tools/worldcom")' \ +-eval '(load "target:tools/comcom")' \ +-eval '(load "target:tools/pclcom")' \ +-eval '(load "target:tools/worldbuild")' \ +-eval '(ext:quit)' + +runtime2: $(RUNTIME2) + +$(RUNTIME2): $(STAGE2DIR)/lisp ; + +$(STAGE2DIR)/lisp: $(KERNELCORE2) + $(MAKE) -C $(STAGE2DIR)/lisp + +.PHONY: $(STAGE2DIR)/lisp + +stage2: $(LISPCORE2) + +$(LISPCORE2): $(KERNELCORE2) $(RUNTIME2) + echo $(LOAD_PCL2) | $(RUNTIME2) -core $(KERNELCORE2) + $(call MOVECORE,$(STAGE2DIR)/lisp,$@) + +cross-build: + bin/create-target.sh xcross + bin/create-target.sh xtarget + cp src/tools/cross-scripts/cross-x86-x86.lisp xtarget/cross.lisp + bin/cross-build-world.sh xtarget xcross xtarget/cross.lisp $(BOOTCMUCL) + bin/rebuild-lisp.sh xtarget + bin/load-world.sh -p xtarget "newlisp" + +sanity: + @if [ `echo $(TOPDIR) | egrep -c '^/'` -ne 1 ]; then \ + echo "ERROR: TOPDIR must be an absolute path: $(TOPDIR)"; \ + exit 1; \ + fi + @if [ ! -r $(TOPDIR)/src/hemlock/abbrev.lisp ] ; then \ + echo "ERROR: No cmucl source tree available at: $(TOPDIR)"; \ + exit 1; \ + fi + @faslfiles=`find -L $(TOPDIR)/src/ -name "*.sse2f"` ; \ + if [ -n "$$faslfiles" ] ; then \ + echo ERROR: Source tree contains fasl files: "$$faslfiles"; \ + exit 1; \ + fi + +sanity-clean: + find -L $(TOPDIR)/src/ ( -name "*.sse2f" -o -name "*.bytef" ) \ + -exec rm -iv {} ; + +clean: sanity-clean + rm -rf $(BUILDDIR) + +clean-xcompiler: sanity-clean + rm -rf $(XCOMPILERDIR) + +clean-world: sanity-clean + rm -rf $(KERNELDIR) + +clean-compiler: sanity-clean + rm -rf $(COMPILERDIR) + +clean-pcl: sanity-clean + rm -rf $(PCLDIR) + +clean-stage2: sanity-clean + rm -rf $(STAGE2DIR) + +rebuild-xcompiler: sanity-clean clean-xcompiler xcompiler +

-----------------------------------------------------------------------

hooks/post-receive