Commit 6bc8fe20 authored by Raymond Toy's avatar Raymond Toy
Browse files

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

parents 8a35f225 eac8d34c
......@@ -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 \
......
......@@ -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))
......@@ -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"
......
......@@ -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.
......@@ -325,10 +330,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,17 +393,19 @@
(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
(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))
......@@ -462,27 +469,29 @@
(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)))
(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)))
(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)))
(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)
......
......@@ -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)
......
......@@ -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))
......
......@@ -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)
......
......@@ -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)))))
......
......@@ -49,14 +49,6 @@
;;; DEBUG-INFO = 3.
;;;
(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)
......@@ -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,17 +217,25 @@
: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))
(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
;;;
......
......@@ -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)))))))
......
......@@ -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))
......@@ -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)))
......
......@@ -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))))))
......
......@@ -903,26 +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))
(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
;;;
;;; Dispatch to the appropriate function, depending on whether we have a
......@@ -950,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))
......@@ -1202,16 +1177,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))))
......@@ -1780,22 +1760,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)
(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
......
......@@ -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)))
......@@ -362,7 +349,9 @@