June 2012 - cmucl-cvs - mailman3.common-lisp.net

[cmucl-cvs] [git] CMU Common Lisp branch tcall-convention created. snapshot-2012-06-54-g6bc8fe2
by Raymond Toy 29 Jun '12

29 Jun '12

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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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(a)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

1 0

[cmucl-cvs] [git] CMU Common Lisp branch file-attribute created. snapshot-2012-06-4-g81f65db
by Raymond Toy 26 Jun '12

26 Jun '12

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, file-attribute has been created at 81f65db452ae1c7c1b8907d10f5bb8bbd4cff37f (commit) - Log ----------------------------------------------------------------- commit 81f65db452ae1c7c1b8907d10f5bb8bbd4cff37f Merge: 7ed7451 8a9d1d8 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon Jun 25 20:46:20 2012 -0700 Merge branch 'master' into file-attribute commit 7ed745111ae7a478ba867db257a1888d2948b524 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu May 24 21:39:39 2012 -0700 First cut at :file-attribute external format (mostly from Douglas.) diff --git a/src/code/exports.lisp b/src/code/exports.lisp index a46d5bb..d0cfe58 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -1511,6 +1511,7 @@ "DESCRIBE-EXTERNAL-FORMAT") ;; Unicode (:export "STRING-TO-OCTETS" "OCTETS-TO-STRING" "*DEFAULT-EXTERNAL-FORMAT*" + "*DEFAULT-SOURCE-EXTERNAL-FORMAT*" "DESCRIBE-EXTERNAL-FORMAT" "LIST-ALL-EXTERNAL-FORMATS" "STRING-ENCODE" "STRING-DECODE" diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 45b5847..e854a73 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -1362,6 +1362,169 @@ ;;;; Utility functions (misc routines, etc) +(defvar *stream-encoding-file-attribute-translations* + '(;; Emacs specific codings. + (:iso8859-1 "latin-1" "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") + (:utf-8 "utf-8-unix") + (:euc-jp "euc-jp-unix") + ) + "List of coding translations used by 'stream-encoding-file-attribute to map + the read file coding into a native external-format. Each element is a list of + a native external-format followed byte a list of coding strings that are to be + mapped to this native format.") + +;;; stream-encoding-file-attribute -- Internal +;;; +;;; Read the encoding file option from the stream 's which is expected to be a +;;; character stream with an external-format of :iso8859-1. +;;; +(defun stream-encoding-file-attribute (s) + (let* ((initial-encoding nil) + (declared-encoding nil) + (buffer (make-array 1024 :element-type '(unsigned-byte 8))) + (available (do ((i 0 (1+ i))) + ((>= i 1024) i) + (declare (fixnum i)) + (let ((ch (read-char s nil nil))) + (unless ch (return i)) + (setf (aref buffer i) (char-code ch)))))) + (labels ((decode-ascii (start size offset) + (declare (type fixnum start) + (type (integer 1 4) size) + (type (integer 0 3) offset)) + (let ((ascii (make-array 64 :element-type 'character + :adjustable t :fill-pointer 0))) + (do () + ((< available (+ start size))) + (let* ((code (ecase size + (1 (aref buffer start)) + (2 (let ((b0 (aref buffer start)) + (b1 (aref buffer (1+ start)))) + (ecase offset + (0 (logior (ash b1 8) b0)) + (1 (logior (ash b0 8) b1))))) + (4 + (let ((b0 (aref buffer start)) + (b1 (aref buffer (+ start 1))) + (b2 (aref buffer (+ start 2))) + (b3 (aref buffer (+ start 3)))) + (ecase offset + (0 (logior (ash b3 24) (ash b2 16) (ash b1 8) b0)) + (1 (logior (ash b1 24) (ash b0 16) (ash b3 8) b2)) + (2 (logior (ash b2 24) (ash b3 16) (ash b0 8) b1)) + (3 (logior (ash b0 24) (ash b1 16) (ash b2 8) b3)))))))) + (incf start size) + (let ((ch (if (< 0 code #x80) (code-char code) #\?))) + (vector-push-extend ch ascii)))) + ascii)) + (parse-file-option (ascii) + ;; Parse the file options. + (let ((found (search "-*-" ascii)) + (options nil)) + (when found + (block do-file-options + (let* ((start (+ found 3)) + (end (search "-*-" ascii :start2 start))) + (unless end + (return-from do-file-options)) + (unless (find #\: ascii :start start :end end) + (return-from do-file-options)) + (do ((opt-start start (1+ semi)) colon semi) + (nil) + (setf colon (position #\: ascii :start opt-start :end end)) + (unless colon + (return-from do-file-options)) + (setf semi (or (position #\; ascii :start colon :end end) end)) + (let ((option (string-trim '(#\space #\tab) + (subseq ascii opt-start colon))) + (value (string-trim '(#\space #\tab) + (subseq ascii (1+ colon) semi)))) + (push (cons option value) options) + (when (= semi end) (return nil))))))) + (setf declared-encoding + (cond ((cdr (assoc "external-format" options :test 'equalp))) + ((cdr (assoc "encoding" options :test 'equalp))) + ((cdr (assoc "coding" options :test 'equalp)))))))) + (cond ((>= available 4) + (let ((b1 (aref buffer 0)) + (b2 (aref buffer 1)) + (b3 (aref buffer 2)) + (b4 (aref buffer 3))) + (cond ((and (= b1 #x00) (= b2 #x00) (= b3 #xFE) (= b4 #xFF)) + (setf initial-encoding :ucs-4be) + (parse-file-option (decode-ascii 4 4 3))) + ((and (= b1 #xff) (= b2 #xfe)) + (cond ((and (= b3 #x00) (= b4 #x00)) + (setf initial-encoding :ucs-4le) + (parse-file-option (decode-ascii 4 4 0))) + (t + (setf initial-encoding :utf-16le) + (parse-file-option (decode-ascii 2 2 0))))) + ((and (= b1 #x00) (= b2 #x00) (= b3 #xFF) (= b4 #xFE)) + (parse-file-option (decode-ascii 4 4 2))) + ((and (= b1 #xfe) (= b2 #xff)) + (cond ((and (= b3 #x00) (= b4 #x00)) + (parse-file-option (decode-ascii 4 4 1))) + (t + (setf initial-encoding :utf-16be) + (parse-file-option (decode-ascii 2 2 1))))) + ((and (= b1 #xEF) (= b2 #xBB) (= b3 #xBF)) + (setf initial-encoding :utf-8)) + ((and (> b1 0) (= b2 0) (= b3 0) (= b4 0)) + (setf initial-encoding :ucs-4le) + (parse-file-option (decode-ascii 0 4 0))) + ((and (= b1 0) (> b2 0) (= b3 0) (= b4 0)) + (parse-file-option (decode-ascii 0 4 1))) + ((and (= b1 0) (= b2 0) (> b3 0) (= b4 0)) + (parse-file-option (decode-ascii 0 4 2))) + ((and (= b1 0) (= b2 0) (= b3 0) (> b4 0)) + (setf initial-encoding :ucs-4be) + (parse-file-option (decode-ascii 0 4 3))) + ((and (> b1 0) (= b2 0) (> b3 0) (= b4 0)) + (setf initial-encoding :utf-16le) + (parse-file-option (decode-ascii 0 2 0))) + ((and (= b1 0) (> b2 0) (= b3 0) (> b4 0)) + (setf initial-encoding :utf-16be) + (parse-file-option (decode-ascii 0 2 1))) + ((and (= b1 #x2B) (= b2 #x41) + (or (= b3 #x43) (= b3 #x44))) + (setf initial-encoding :utf-7)) + ((and (= b1 #x2F) (= b2 #x2B) (= b3 #x41)) + (setf initial-encoding :utf-7)) + (t + (parse-file-option (decode-ascii 0 1 0)))))) + ((= available 3) + (when (and (= (aref buffer 0) #xEF) + (= (aref buffer 1) #xBB) + (= (aref buffer 2) #xBF)) + (setf initial-encoding :utf-8))) + ((= available 2) + (let ((b1 (aref buffer 0)) + (b2 (aref buffer 1))) + (cond ((and (= b1 #xff) (= b2 #xfe)) + (setf initial-encoding :utf-16le)) + ((and (= b1 #xfe) (= b2 #xff)) + (setf initial-encoding :utf-16be))))))) + ;; + ;; + (cond ((and (not initial-encoding) (not declared-encoding)) + :default) + (t + (let ((encoding (or declared-encoding initial-encoding))) + (when (stringp encoding) + (setf encoding (string-upcase encoding)) + (dolist (translations *stream-encoding-file-attribute-translations*) + (when (member encoding (rest translations) :test 'equalp) + (setf encoding (first translations)) + (return)))) + (let ((external-format + (cond ((eq encoding :default) :default) + ((stringp encoding) + (intern encoding :keyword)) + (t + encoding)))) + external-format)))))) + ;;; SET-ROUTINES -- internal ;;; ;;; Fill in the various routine slots for the given type. Input-p and @@ -1916,20 +2079,7 @@ (setf (fd-stream-flags stream) #b001)) (t (setf (fd-stream-flags stream) #b010))) - - ;; FIXME: setting the external format here should be better - ;; integrated into set-routines. We do it before so that - ;; set-routines can create an in-buffer if appropriate. But we - ;; need to do it after to put the correct input routines for the - ;; external format. ;; - ;;#-unicode-bootstrap ; fails in stream-reinit otherwise - #+(and unicode (not unicode-bootstrap)) - (%set-fd-stream-external-format stream external-format nil) - (set-routines stream element-type input output input-buffer-p - :binary-stream-p binary-stream-p) - #+(and unicode (not unicode-bootstrap)) - (%set-fd-stream-external-format stream external-format nil) (when (and auto-close (fboundp 'finalize)) (finalize stream #'(lambda () @@ -1937,6 +2087,46 @@ (format *terminal-io* (intl:gettext "** Closed ~A~%") name) (when original (revert-file file original))))) + ;; + ;; FIXME: setting the external format here should be better + ;; integrated into set-routines. We do it before so that + ;; set-routines can create an in-buffer if appropriate. But we + ;; need to do it after to put the correct input routines for the + ;; external format. + ;; + ;;#-unicode-bootstrap ; fails in stream-reinit otherwise + #+(and unicode (not unicode-bootstrap)) + (cond ((and (eq external-format :file-attribute) input) + ;; Read the encoding file option with the external-format set to + ;; :iso8859-1, and then change the external-format if necessary. + #+(and unicode (not unicode-bootstrap)) + (%set-fd-stream-external-format stream :iso8859-1 nil) + (set-routines stream element-type input output input-buffer-p + :binary-stream-p binary-stream-p) + #+(and unicode (not unicode-bootstrap)) + (%set-fd-stream-external-format stream :iso8859-1 nil) + (let ((encoding (stream-encoding-file-attribute stream))) + (unless (file-position stream :start) + (error (intl:gettext "The ~A external-format requires a file stream.") + external-format)) + (unless (member encoding '(:iso8859-1 :iso-8859-1)) + (setf (stream-external-format stream) (or encoding :default))))) + ((eq external-format :file-attribute) + ;; Non-input stream, so can not read the file attributes, so use the + ;; :default. + #+(and unicode (not unicode-bootstrap)) + (%set-fd-stream-external-format stream :default nil) + (set-routines stream element-type input output input-buffer-p + :binary-stream-p binary-stream-p) + #+(and unicode (not unicode-bootstrap)) + (%set-fd-stream-external-format stream :default nil)) + (t + #+(and unicode (not unicode-bootstrap)) + (%set-fd-stream-external-format stream external-format nil) + (set-routines stream element-type input output input-buffer-p + :binary-stream-p binary-stream-p) + #+(and unicode (not unicode-bootstrap)) + (%set-fd-stream-external-format stream external-format nil))) stream)) diff --git a/src/code/load.lisp b/src/code/load.lisp index 832853b..89f7705 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -19,7 +19,7 @@ (in-package "EXTENSIONS") (export '(*load-if-source-newer* *load-source-types* *load-object-types* - invalid-fasl)) + invalid-fasl *default-source-external-format*)) (in-package "SYSTEM") (export '(foreign-symbol-address alternate-get-global-address)) @@ -94,6 +94,12 @@ (invalid-fasl-pathname condition) (invalid-fasl-version condition) (invalid-fasl-expected-version condition))))) + +(defvar *default-source-external-format* :default + "The external-format that 'load and 'compile-file use when given an + external-format of :default. The default value is :default which will open + the file using the 'ext:*default-external-format*") + ;;; LOAD-FRESH-LINE -- internal. ;;; @@ -523,6 +529,10 @@ defaulting. Probably only necessary if you have source files with a \"fasl\" type. + :EXTERNAL-FORMAT + The external-format to use when opening the FILENAME. The default is + :default which uses the EXT:*DEFAULT-SOURCE-EXTERNAL-FORMAT*. + The variables *LOAD-VERBOSE*, *LOAD-PRINT* and EXT:*LOAD-IF-SOURCE-NEWER* determine the defaults for the corresponding keyword arguments. These variables are also bound to the specified argument values, so specifying a @@ -604,6 +614,8 @@ (*load-pathname* pathname)) (case contents (:source + (when (eq external-format :default) + (setf external-format *default-source-external-format*)) (with-open-file (file truename :external-format external-format :direction :input :if-does-not-exist if-does-not-exist) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 544ccb0..066ff2d 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -738,12 +738,12 @@ :write-date (file-write-date x) :language :lisp)) files))) - + (when (eq external-format :default) + (setf external-format *default-source-external-format*)) (make-source-info :files file-info :current-file file-info #+unicode :external-format - #+unicode (stream::ef-name - (stream::find-external-format external-format)) + #+unicode external-format #+unicode :decoding-error #+unicode decoding-error))) diff --git a/src/i18n/locale/cmucl.pot b/src/i18n/locale/cmucl.pot index 5b38108..bb807f4 100644 --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -9187,6 +9187,16 @@ msgid "Error reading ~S: ~A" msgstr "" #: src/code/fd-stream.lisp +msgid "" +"List of coding translations used by 'stream-encoding-file-attribute to map\n" +" the read file coding into a native external-format. Each element is a " +"list of\n" +" a native external-format followed byte a list of coding strings that are " +"to be\n" +" mapped to this native format." +msgstr "" + +#: src/code/fd-stream.lisp msgid "Could not find any input routine for ~S" msgstr "" @@ -9263,6 +9273,10 @@ msgid "** Closed ~A~%" msgstr "" #: src/code/fd-stream.lisp +msgid "The ~A external-format requires a file stream." +msgstr "" + +#: src/code/fd-stream.lisp msgid "" "This is a string that OPEN tacks on the end of a file namestring to produce\n" " a name for the :if-exists :rename-and-delete and :rename options. Also,\n" @@ -10064,6 +10078,14 @@ msgid "" msgstr "" #: src/code/load.lisp +msgid "" +"The external-format that 'load and 'compile-file use when given an\n" +" external-format of :default. The default value is :default which will " +"open\n" +" the file using the 'ext:*default-external-format*" +msgstr "" + +#: src/code/load.lisp msgid "List of free fop tables for the fasloader." msgstr "" @@ -10133,6 +10155,10 @@ msgid "" " defaulting. Probably only necessary if you have source files with a\n" " \"fasl\" type. \n" "\n" +" :EXTERNAL-FORMAT\n" +" The external-format to use when opening the FILENAME. The default is\n" +" :default which uses the EXT:*DEFAULT-SOURCE-EXTERNAL-FORMAT*.\n" +"\n" " The variables *LOAD-VERBOSE*, *LOAD-PRINT* and EXT:*LOAD-IF-SOURCE-NEWER" "*\n" " determine the defaults for the corresponding keyword arguments. These\n" ----------------------------------------------------------------------- hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-06-2-g8a9d1d8
by Raymond Toy 15 Jun '12

15 Jun '12

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, master has been updated via 8a9d1d8d186004b5bd3354f2f9e0d0cc4b307d86 (commit) from b0e85da9332a8822dd9496a0e4a72571b6d3546b (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 8a9d1d8d186004b5bd3354f2f9e0d0cc4b307d86 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Jun 15 12:52:24 2012 -0700 Change min_av_mem_age to be an int instead of double. No floating point operations should occur in allocation or GC now, except when printing stats. diff --git a/src/lisp/gencgc.c b/src/lisp/gencgc.c index f8aed88..1e20421 100644 --- a/src/lisp/gencgc.c +++ b/src/lisp/gencgc.c @@ -451,6 +451,9 @@ gc_write_barrier(void *addr) /* * A structure to hold the state of a generation. */ +#define MEM_AGE_SHIFT 16 +#define MEM_AGE_SCALE (1 << MEM_AGE_SHIFT) + struct generation { /* The first page that gc_alloc checks on its next call. */ @@ -502,8 +505,11 @@ struct generation { * A minimum average memory age before a GC will occur helps prevent * a GC when a large number of new live objects have been added, in * which case a GC could be a waste of time. + * + * The age is represented as an integer between 0 and 32767 + * corresponding to an age of 0 to (just less than) 1. */ - double min_av_mem_age; + int min_av_mem_age; }; /* @@ -524,7 +530,7 @@ struct generation_stats { int num_gc; int trigger_age; int cum_sum_bytes_allocated; - double min_av_mem_age; + int min_av_mem_age; }; @@ -647,14 +653,14 @@ generation_bytes_allocated(int generation) /* * Return the average age of the memory in a generation. */ -static double +static int gen_av_mem_age(int gen) { if (generations[gen].bytes_allocated == 0) - return 0.0; + return 0; - return (double) generations[gen].cum_sum_bytes_allocated / - (double) generations[gen].bytes_allocated; + return (((long) generations[gen].cum_sum_bytes_allocated) << MEM_AGE_SHIFT) / + generations[gen].bytes_allocated; } /* @@ -753,7 +759,7 @@ print_generation_stats(int verbose) GC_PAGE_SIZE * count_generation_pages(i) - generations[i].bytes_allocated, generations[i].gc_trigger, count_write_protect_generation_pages(i), generations[i].num_gc, - gen_av_mem_age(i)); + (double)gen_av_mem_age(i) / MEM_AGE_SCALE); } fprintf(stderr, " Total bytes alloc=%ld\n", bytes_allocated); @@ -804,7 +810,7 @@ void set_min_mem_age(int gen, double min_mem_age) { if (gen <= NUM_GENERATIONS) { - generations[gen].min_av_mem_age = min_mem_age; + generations[gen].min_av_mem_age = min_mem_age * MEM_AGE_SCALE; } } @@ -4532,7 +4538,20 @@ scav_hash_vector(lispobj * where, lispobj object) fprintf(stderr, "scav_hash_vector: scavenge table %p\n", hash_table); } #endif - + +#ifdef GC_ASSERTIONS + { + /* + * Check to see that hash-table-rehash-threshold is a single + * float in the range (0, 1] + */ + lispobj threshold_obj = (lispobj) hash_table->rehash_threshold; + float* raw_slots = PTR(threshold_obj); + float threshold = raw_slots[2]; + gc_assert(threshold > 0 && threshold <= 1); + } +#endif + scavenge((lispobj *) hash_table, HASH_TABLE_SIZE); if (hash_table->weak_p == NIL) { @@ -7325,7 +7344,7 @@ garbage_collect_generation(int generation, int raise) #ifdef GC_ASSERTIONS #if defined(i386) || defined(__x86_64) - invalid_stack_start = (void *) control_stack_start; + invalid_stack_start = (void *) CONTROL_STACK_START; invalid_stack_end = (void *) &raise; #else /* not i386 */ invalid_stack_start = (void *) &raise; @@ -7897,7 +7916,7 @@ gc_init(void) /* The tune-able parameters */ generations[i].bytes_consed_between_gc = 2000000; generations[i].trigger_age = 1; - generations[i].min_av_mem_age = 0.75; + generations[i].min_av_mem_age = 24508; /* 0.75 * MEM_AGE_SCALE */ } /* Initialise gc_alloc */ ----------------------------------------------------------------------- Summary of changes: src/lisp/gencgc.c | 41 ++++++++++++++++++++++++++++++----------- 1 files changed, 30 insertions(+), 11 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-06-1-gb0e85da
by Raymond Toy 15 Jun '12

15 Jun '12

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, master has been updated via b0e85da9332a8822dd9496a0e4a72571b6d3546b (commit) from 94321e988a142e938548e3be07c8cbaf3077211d (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit b0e85da9332a8822dd9496a0e4a72571b6d3546b Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Jun 15 12:19:47 2012 -0700 Update to asdf 2.22. Testsuite for asdf, using 2012-06, passes fine. diff --git a/src/contrib/asdf/asdf.lisp b/src/contrib/asdf/asdf.lisp index b7ad1dd..5981f67 100644 --- a/src/contrib/asdf/asdf.lisp +++ b/src/contrib/asdf/asdf.lisp @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- -;;; This is ASDF 2.21: Another System Definition Facility. +;;; This is ASDF 2.22: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel(a)common-lisp.net>. @@ -116,7 +116,7 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.21") + (asdf-version "2.22") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -1343,7 +1343,7 @@ processed in order by OPERATE.")) :initarg :if-component-dep-fails :accessor module-if-component-dep-fails) (default-component-class - :initform *default-component-class* + :initform nil :initarg :default-component-class :accessor module-default-component-class))) @@ -2788,6 +2788,11 @@ details." directory-pathname (default-directory)))) +(defun* find-class* (x &optional (errorp t) environment) + (etypecase x + ((or standard-class built-in-class) x) + (symbol (find-class x errorp environment)))) + (defun* class-for-type (parent type) (or (loop :for symbol :in (list type @@ -2799,8 +2804,10 @@ details." class (find-class 'component))) :return class) (and (eq type :file) - (or (and parent (module-default-component-class parent)) - (find-class *default-component-class*))) + (find-class* + (or (loop :for module = parent :then (component-parent module) :while module + :thereis (module-default-component-class module)) + *default-component-class*) nil)) (sysdef-error "don't recognize component type ~A" type))) (defun* maybe-add-tree (tree op1 op2 c) @@ -2886,7 +2893,7 @@ Returns the new tree (which probably shares structure with the old one)" (type name &rest rest &key ;; the following list of keywords is reproduced below in the ;; remove-keys form. important to keep them in sync - components pathname default-component-class + components pathname perform explain output-files operation-done-p weakly-depends-on depends-on serial in-order-to do-first @@ -2913,7 +2920,7 @@ Returns the new tree (which probably shares structure with the old one)" :pathname pathname :parent parent (remove-keys - '(components pathname default-component-class + '(components pathname perform explain output-files operation-done-p weakly-depends-on depends-on serial in-order-to) rest))) @@ -2927,10 +2934,6 @@ Returns the new tree (which probably shares structure with the old one)" (setf ret (apply 'make-instance (class-for-type parent type) args))) (component-pathname ret) ; eagerly compute the absolute pathname (when (typep ret 'module) - (setf (module-default-component-class ret) - (or default-component-class - (and (typep parent 'module) - (module-default-component-class parent)))) (let ((*serial-depends-on* nil)) (setf (module-components ret) (loop @@ -3687,7 +3690,7 @@ Please remove it from your ASDF configuration")) #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ()))) ;; The below two are not needed: no precompiled ASDF system there - ;; #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) + #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ;; All-import, here is where we want user stuff to be: :inherit-configuration @@ -4011,21 +4014,24 @@ with a different configuration, so the configuration would be re-read then." entries)) (defun* directory-files (directory &optional (pattern *wild-file*)) - (setf directory (pathname directory)) - (when (wild-pathname-p directory) - (error "Invalid wild in ~S" directory)) - (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) - (error "Invalid file pattern ~S" pattern)) - (when (typep directory 'logical-pathname) - (setf pattern (make-pathname-logical pattern (pathname-host directory)))) - (let ((entries (ignore-errors (directory* (merge-pathnames* pattern directory))))) - (filter-logical-directory-results - directory entries - #'(lambda (f) - (make-pathname :defaults directory - :name (pathname-name f) - :type (make-pathname-component-logical (pathname-type f)) - :version (make-pathname-component-logical (pathname-version f))))))) + (let ((dir (pathname directory))) + (when (typep dir 'logical-pathname) + ;; Because of the filtering we do below, + ;; logical pathnames have restrictions on wild patterns. + ;; Not that the results are very portable when you use these patterns on physical pathnames. + (when (wild-pathname-p dir) + (error "Invalid wild pattern in logical directory ~S" directory)) + (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) + (error "Invalid file pattern ~S for logical directory ~S" pattern directory)) + (setf pattern (make-pathname-logical pattern (pathname-host dir)))) + (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir))))) + (filter-logical-directory-results + directory entries + #'(lambda (f) + (make-pathname :defaults dir + :name (make-pathname-component-logical (pathname-name f)) + :type (make-pathname-component-logical (pathname-type f)) + :version (make-pathname-component-logical (pathname-version f)))))))) (defun* directory-asd-files (directory) (directory-files directory *wild-asd*)) @@ -4399,7 +4405,7 @@ with a different configuration, so the configuration would be re-read then." (let ((*verbose-out* (make-broadcast-stream)) (system (find-system (string-downcase name) nil))) (when system - (operate *require-asdf-operator* system :verbose nil) + (operate *require-asdf-operator* system :verbose nil :force-not (loaded-systems)) t)))) #+(or abcl clisp clozure cmu ecl sbcl) diff --git a/src/general-info/release-20d.txt b/src/general-info/release-20d.txt index e2b20e8..631fcca 100644 --- a/src/general-info/release-20d.txt +++ b/src/general-info/release-20d.txt @@ -30,7 +30,7 @@ New in this release: * Added external format for EUC-KR. * Changes - * ASDF2 updated to version 2.21. + * ASDF2 updated to version 2.22. * Behavior of STRING-TO-OCTETS has changed. This is an incompatible change from the previous version but should be more useful when a buffer is given which is not large enough to hold ----------------------------------------------------------------------- Summary of changes: src/contrib/asdf/asdf.lisp | 62 +++++++++++++++++++++----------------- src/general-info/release-20d.txt | 2 +- 2 files changed, 35 insertions(+), 29 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp annotated tag snapshot-2012-06 created. snapshot-2012-06
by Raymond Toy 12 Jun '12

12 Jun '12

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 annotated tag, snapshot-2012-06 has been created at 036e8b607ab2ddcf1717fb0918a68aee8278ee2f (tag) tagging 94321e988a142e938548e3be07c8cbaf3077211d (commit) replaces snapshot-2012-05 tagged by Raymond Toy on Mon Jun 11 20:57:00 2012 -0700 - Log ----------------------------------------------------------------- Snapshot 2012-06 Raymond Toy (20): Link to www.cmucl.org. Add popcnt instruction and use it in logcount vop if :sse3 is a Clear matching current exceptions when enabling new exceptions. This First cut at :file-attribute external-format that determines the * {{{COMPILE-FILE}}} should not signal an error when given a list for Add all the emacs format encodings. From Douglas. Debugger needs to open file with the appropriate external format. Use concatenate instead of format because format isn't available when Fix so this can build on 8-bit cmucl. Fix ticket:60 Update with changes. Merge branch 'master' into ext-format-file-attribute Remove extra closing parenthesis. Update with new :FILE-ATTRIBUTE external format, contributed by Revert :file-attribute changes. Update. Update translation template. Don't set dimension of array to 1 for the rest slots of a primitive Add comments about using clang instead of gcc on x86. Oops. Didn't mean for the gencgc.o rule to get included. ----------------------------------------------------------------------- hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-05-20-g94321e9
by Raymond Toy 12 Jun '12

12 Jun '12

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, master has been updated via 94321e988a142e938548e3be07c8cbaf3077211d (commit) from 86f6dccd0b106765670265e0cf0c7ce2e6a84b55 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 94321e988a142e938548e3be07c8cbaf3077211d Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon Jun 11 20:54:47 2012 -0700 Oops. Didn't mean for the gencgc.o rule to get included. diff --git a/src/lisp/Config.x86_common b/src/lisp/Config.x86_common index 0fa9bb3..edf4476 100644 --- a/src/lisp/Config.x86_common +++ b/src/lisp/Config.x86_common @@ -88,6 +88,3 @@ DEPEND_FLAGS = e_rem_pio2.o : e_rem_pio2.c $(CC) -c $(CFLAGS) $(CPPFLAGS) $< -# -gencgc.o : gencgc.c - $(CC) -c -mno-sse $(CFLAGS) $(CPPFLAGS) $< \ No newline at end of file ----------------------------------------------------------------------- Summary of changes: src/lisp/Config.x86_common | 3 --- 1 files changed, 0 insertions(+), 3 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-05-19-g86f6dcc
by Raymond Toy 02 Jun '12

02 Jun '12

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, master has been updated via 86f6dccd0b106765670265e0cf0c7ce2e6a84b55 (commit) from 0d6f20340333a05b1f990056b38ffb77083de2f1 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 86f6dccd0b106765670265e0cf0c7ce2e6a84b55 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Jun 2 15:02:00 2012 -0700 Add comments about using clang instead of gcc on x86. diff --git a/src/lisp/Config.x86_common b/src/lisp/Config.x86_common index 5ed23de..0fa9bb3 100644 --- a/src/lisp/Config.x86_common +++ b/src/lisp/Config.x86_common @@ -45,7 +45,24 @@ ifdef FEATURE_UNICODE CPP_DEFINE_OPTIONS += -DUNICODE endif +# Default to using gcc CC = gcc + +# But we can use clang. +# +# However, clang seems to want to use SSE instructions in various +# places, but we DON'T want that because we need a lisp that will run +# on chips without sse. +# +# But on Mac, every machine has SSE2 so we can use SSE2. However, +# there's some code path through GC or allocation where we aren't +# saving the FPU state so after GC or allocation, some XMM FP +# registers are corrupted. +# +# Got that? + +#CC = clang -mno-sse + LD = ld ifeq ($(filter 2% 3%, $(shell $(CC) -dumpversion)),) @@ -70,3 +87,7 @@ DEPEND_FLAGS = # -ffloat-store and -fno-strict-aliasing anymore. e_rem_pio2.o : e_rem_pio2.c $(CC) -c $(CFLAGS) $(CPPFLAGS) $< + +# +gencgc.o : gencgc.c + $(CC) -c -mno-sse $(CFLAGS) $(CPPFLAGS) $< \ No newline at end of file ----------------------------------------------------------------------- Summary of changes: src/lisp/Config.x86_common | 21 +++++++++++++++++++++ 1 files changed, 21 insertions(+), 0 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-05-18-g0d6f203
by Raymond Toy 01 Jun '12

01 Jun '12

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, master has been updated via 0d6f20340333a05b1f990056b38ffb77083de2f1 (commit) via 7095ad43fd8997c759041e046ffc251fb9685011 (commit) via 27f601d7cef020a11b2ae18e0337319385d1fb2e (commit) from f8b368ffa9fbcf75cac9a7ed1d5551e1d57ae76b (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 0d6f20340333a05b1f990056b38ffb77083de2f1 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu May 31 21:25:33 2012 -0700 Don't set dimension of array to 1 for the rest slots of a primitive object. diff --git a/src/compiler/generic/new-genesis.lisp b/src/compiler/generic/new-genesis.lisp index 9523d41..953d9ba 100644 --- a/src/compiler/generic/new-genesis.lisp +++ b/src/compiler/generic/new-genesis.lisp @@ -2570,7 +2570,7 @@ (when (vm:primitive-object-header obj) (format t " lispobj header;~%")) (dolist (slot (vm:primitive-object-slots obj)) - (format t " ~A ~A~@[[1]~];~%" + (format t " ~A ~A~@[[]~];~%" (getf (vm:slot-options slot) :c-type "lispobj") (nsubstitute #\_ #\- (string-downcase (string (vm:slot-name slot)))) commit 7095ad43fd8997c759041e046ffc251fb9685011 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu May 31 19:55:27 2012 -0700 Update translation template. diff --git a/src/i18n/locale/cmucl.pot b/src/i18n/locale/cmucl.pot index bb807f4..6a45d45 100644 --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -9187,16 +9187,6 @@ msgid "Error reading ~S: ~A" msgstr "" #: src/code/fd-stream.lisp -msgid "" -"List of coding translations used by 'stream-encoding-file-attribute to map\n" -" the read file coding into a native external-format. Each element is a " -"list of\n" -" a native external-format followed byte a list of coding strings that are " -"to be\n" -" mapped to this native format." -msgstr "" - -#: src/code/fd-stream.lisp msgid "Could not find any input routine for ~S" msgstr "" @@ -9273,10 +9263,6 @@ msgid "** Closed ~A~%" msgstr "" #: src/code/fd-stream.lisp -msgid "The ~A external-format requires a file stream." -msgstr "" - -#: src/code/fd-stream.lisp msgid "" "This is a string that OPEN tacks on the end of a file namestring to produce\n" " a name for the :if-exists :rename-and-delete and :rename options. Also,\n" @@ -10078,14 +10064,6 @@ msgid "" msgstr "" #: src/code/load.lisp -msgid "" -"The external-format that 'load and 'compile-file use when given an\n" -" external-format of :default. The default value is :default which will " -"open\n" -" the file using the 'ext:*default-external-format*" -msgstr "" - -#: src/code/load.lisp msgid "List of free fop tables for the fasloader." msgstr "" @@ -10157,7 +10135,7 @@ msgid "" "\n" " :EXTERNAL-FORMAT\n" " The external-format to use when opening the FILENAME. The default is\n" -" :default which uses the EXT:*DEFAULT-SOURCE-EXTERNAL-FORMAT*.\n" +" :default which uses the EXT:*DEFAULT-EXTERNAL-FORMAT*.\n" "\n" " The variables *LOAD-VERBOSE*, *LOAD-PRINT* and EXT:*LOAD-IF-SOURCE-NEWER" "*\n" commit 27f601d7cef020a11b2ae18e0337319385d1fb2e Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Tue May 29 20:17:47 2012 -0700 Update. diff --git a/src/general-info/release-20d.txt b/src/general-info/release-20d.txt index f176b8b..e2b20e8 100644 --- a/src/general-info/release-20d.txt +++ b/src/general-info/release-20d.txt @@ -28,10 +28,6 @@ New in this release: double-float) numbers. Utility functions are provided to set and access these packed numbers. * Added external format for EUC-KR. - * Added new external format, :FILE-ATTRIBUTE, which looks for an - emacs mode-line to determine the encoding to use for reading a - file. The end-of-line sequence is also determined from reading - the file. * Changes * ASDF2 updated to version 2.21. @@ -54,11 +50,6 @@ New in this release: enabling a trap when the current exception also listed that trap caused the exception to be immediately signaled. This no longer happens and now matches how ppc and sparc behave. - * The default external-format for COMPILE-FILE and LOAD is now - given by *DEFAULT-SOURCE-EXTERNAL-FORMAT*, instead of - *DEFAULT-EXTERNAL-FORMAT*. However, the default value of - *DEFAULT-SOURCE-EXTERNAL-FORMAT* is :DEFAULT, which means the - value of *DEFAULT-EXTERNAL-FORMAT* will be used. * ANSI compliance fixes: * CMUCL was not printing pathnames like (make-pathname :directory ----------------------------------------------------------------------- Summary of changes: src/compiler/generic/new-genesis.lisp | 2 +- src/general-info/release-20d.txt | 9 --------- src/i18n/locale/cmucl.pot | 24 +----------------------- 3 files changed, 2 insertions(+), 33 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0