[cmucl-cvs] [git] CMU Common Lisp branch tcall-convention created. snapshot-2012-06-54-g6bc8fe2
Raymond Toy
rtoy at common-lisp.net
Fri Jun 29 04:27:12 UTC 2012
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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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 at 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
--
CMU Common Lisp
More information about the cmucl-cvs
mailing list