Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/compiler ir1tran-lambda.lisp,1.1,1.2 ir1tran.lisp,1.106,1.107 ir1util.lisp,1.60,1.61 locall.lisp,1.47,1.48 main.lisp,1.71,1.72 node.lisp,1.40,1.41
|
From: Alexey D. <ade...@us...> - 2003-06-04 06:03:16
|
Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs1:/tmp/cvs-serv24705/src/compiler
Modified Files:
ir1tran-lambda.lisp ir1tran.lisp ir1util.lisp locall.lisp
main.lisp node.lisp
Log Message:
0.8.0.31:
Optional entry points are converted on demand.
Index: ir1tran-lambda.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1tran-lambda.lisp,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- ir1tran-lambda.lisp 4 Jun 2003 05:58:18 -0000 1.1
+++ ir1tran-lambda.lisp 4 Jun 2003 06:03:11 -0000 1.2
@@ -24,7 +24,7 @@
;;; If it is losing, we punt with a COMPILER-ERROR. NAMES-SO-FAR is a
;;; list of names which have previously been bound. If the NAME is in
;;; this list, then we error out.
-(declaim (ftype (function (t list) lambda-var) varify-lambda-arg))
+(declaim (ftype (sfunction (t list) lambda-var) varify-lambda-arg))
(defun varify-lambda-arg (name names-so-far)
(declare (inline member))
(unless (symbolp name)
@@ -47,7 +47,7 @@
;;; Make the default keyword for a &KEY arg, checking that the keyword
;;; isn't already used by one of the VARS.
-(declaim (ftype (function (symbol list t) keyword) make-keyword-for-arg))
+(declaim (ftype (sfunction (symbol list t) keyword) make-keyword-for-arg))
(defun make-keyword-for-arg (symbol vars keywordify)
(let ((key (if (and keywordify (not (keywordp symbol)))
(keywordicate symbol)
@@ -74,7 +74,7 @@
;;; 3. a flag indicating whether other &KEY args are allowed;
;;; 4. a list of the &AUX variables; and
;;; 5. a list of the &AUX values.
-(declaim (ftype (function (list) (values list boolean boolean list list))
+(declaim (ftype (sfunction (list) (values list boolean boolean list list))
make-lambda-vars))
(defun make-lambda-vars (list)
(multiple-value-bind (required optional restp rest keyp keys allowp auxp aux
@@ -351,10 +351,20 @@
lambda))
+;;; Entry point CLAMBDAs have a special kind
+(defun register-entry-point (entry dispatcher)
+ (declare (type clambda entry)
+ (type optional-dispatch dispatcher))
+ (setf (functional-kind entry) :optional)
+ (setf (leaf-ever-used entry) t)
+ (setf (lambda-optional-dispatch entry)
+ dispatcher)
+ entry)
+
;;; Create the actual entry-point function for an optional entry
;;; point. The lambda binds copies of each of the VARS, then calls FUN
;;; with the argument VALS and the DEFAULTS. Presumably the VALS refer
-;;; to the VARS by name. The VALS are passed in in reverse order.
+;;; to the VARS by name. The VALS are passed in the reverse order.
;;;
;;; If any of the copies of the vars are referenced more than once,
;;; then we mark the corresponding var as EVER-USED to inhibit
@@ -383,7 +393,9 @@
,@(reverse vals)
,@(default-vals))))
arg-vars
- :debug-name "&OPTIONAL processor"
+ :debug-name
+ (debug-namify "&OPTIONAL processor ~D"
+ (random 100))
:note-lexical-bindings nil))))
(mapc (lambda (var arg-var)
(when (cdr (leaf-refs arg-var))
@@ -398,10 +410,11 @@
;;; var, then we add it into the default vars and throw a T into the
;;; entry values. The resulting entry point function is returned.
(defun generate-optional-default-entry (res default-vars default-vals
- entry-vars entry-vals
- vars supplied-p-p body
- aux-vars aux-vals cont
- source-name debug-name)
+ entry-vars entry-vals
+ vars supplied-p-p body
+ aux-vars aux-vals cont
+ source-name debug-name
+ force)
(declare (type optional-dispatch res)
(list default-vars default-vals entry-vars entry-vals vars body
aux-vars aux-vals)
@@ -409,7 +422,10 @@
(let* ((arg (first vars))
(arg-name (leaf-source-name arg))
(info (lambda-var-arg-info arg))
- (supplied-p (arg-info-supplied-p info))
+ (default (arg-info-default info))
+ (supplied-p (arg-info-supplied-p info))
+ (force (or force
+ (not (sb!xc:constantp (arg-info-default info)))))
(ep (if supplied-p
(ir1-convert-hairy-args
res
@@ -418,7 +434,8 @@
(cons arg entry-vars)
(list* t arg-name entry-vals)
(rest vars) t body aux-vars aux-vals cont
- source-name debug-name)
+ source-name debug-name
+ force)
(ir1-convert-hairy-args
res
(cons arg default-vars)
@@ -426,12 +443,29 @@
(cons arg entry-vars)
(cons arg-name entry-vals)
(rest vars) supplied-p-p body aux-vars aux-vals cont
- source-name debug-name))))
+ source-name debug-name
+ force))))
- (convert-optional-entry ep default-vars default-vals
- (if supplied-p
- (list (arg-info-default info) nil)
- (list (arg-info-default info))))))
+ ;; We want to delay converting the entry, but there exist
+ ;; problems: hidden references should not be established to
+ ;; lambdas of kind NIL should not have (otherwise the compiler
+ ;; might let-convert or delete them) and to variables.
+ (if (or force
+ supplied-p-p ; this entry will be of kind NIL
+ (and (lambda-p ep) (eq (lambda-kind ep) nil)))
+ (convert-optional-entry ep
+ default-vars default-vals
+ (if supplied-p
+ (list default nil)
+ (list default)))
+ (delay
+ (register-entry-point
+ (convert-optional-entry (force ep)
+ default-vars default-vals
+ (if supplied-p
+ (list default nil)
+ (list default)))
+ res)))))
;;; Create the MORE-ENTRY function for the OPTIONAL-DISPATCH RES.
;;; ENTRY-VARS and ENTRY-VALS describe the fixed arguments. REST is
@@ -557,7 +591,8 @@
(arg-vars)
:debug-name (debug-namify "~S processing" '&more)
:note-lexical-bindings nil)))
- (setf (optional-dispatch-more-entry res) ep))))
+ (setf (optional-dispatch-more-entry res)
+ (register-entry-point ep res)))))
(values))
@@ -647,12 +682,15 @@
debug-name))))
(last-entry (convert-optional-entry main-entry default-vars
(main-vals) ())))
- (setf (optional-dispatch-main-entry res) main-entry)
+ (setf (optional-dispatch-main-entry res)
+ (register-entry-point main-entry res))
(convert-more-entry res entry-vars entry-vals rest more-context keys)
- (push (if supplied-p-p
+ (push (register-entry-point
+ (if supplied-p-p
(convert-optional-entry last-entry entry-vars entry-vals ())
last-entry)
+ res)
(optional-dispatch-entry-points res))
last-entry)))
@@ -689,10 +727,11 @@
;;; When we run into a &REST or &KEY arg, we punt out to
;;; IR1-CONVERT-MORE, which finishes for us in this case.
(defun ir1-convert-hairy-args (res default-vars default-vals
- entry-vars entry-vals
- vars supplied-p-p body aux-vars
- aux-vals cont
- source-name debug-name)
+ entry-vars entry-vals
+ vars supplied-p-p body aux-vars
+ aux-vals cont
+ source-name debug-name
+ force)
(declare (type optional-dispatch res)
(list default-vars default-vals entry-vars entry-vals vars body
aux-vars aux-vals)
@@ -714,9 +753,12 @@
(as-debug-name source-name
debug-name)))))
(setf (optional-dispatch-main-entry res) fun)
+ (register-entry-point fun res)
(push (if supplied-p-p
- (convert-optional-entry fun entry-vars entry-vals ())
- fun)
+ (register-entry-point
+ (convert-optional-entry fun entry-vars entry-vals ())
+ res)
+ fun)
(optional-dispatch-entry-points res))
fun)))
((not (lambda-var-arg-info (first vars)))
@@ -726,7 +768,8 @@
(ir1-convert-hairy-args res nvars nvals nvars nvals
(rest vars) nil body aux-vars aux-vals
cont
- source-name debug-name)))
+ source-name debug-name
+ nil)))
(t
(let* ((arg (first vars))
(info (lambda-var-arg-info arg))
@@ -737,10 +780,17 @@
res default-vars default-vals
entry-vars entry-vals vars supplied-p-p body
aux-vars aux-vals cont
- source-name debug-name)))
- (push (if supplied-p-p
- (convert-optional-entry ep entry-vars entry-vals ())
- ep)
+ source-name debug-name
+ force)))
+ ;; See GENERATE-OPTIONAL-DEFAULT-ENTRY.
+ (push (if (lambda-p ep)
+ (register-entry-point
+ (if supplied-p-p
+ (convert-optional-entry ep entry-vars entry-vals ())
+ ep)
+ res)
+ (progn (aver (not supplied-p-p))
+ ep))
(optional-dispatch-entry-points res))
ep))
(:rest
@@ -776,25 +826,19 @@
:allowp allowp
:keyp keyp
:%source-name source-name
- :%debug-name debug-name))
+ :%debug-name debug-name
+ :plist `(:ir1-environment
+ (,*lexenv*
+ ,*current-path*))))
(min (or (position-if #'lambda-var-arg-info vars) (length vars))))
(aver-live-component *current-component*)
(push res (component-new-functionals *current-component*))
(ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals
- cont source-name debug-name)
+ cont source-name debug-name nil)
(setf (optional-dispatch-min-args res) min)
(setf (optional-dispatch-max-args res)
(+ (1- (length (optional-dispatch-entry-points res))) min))
- (flet ((frob (ep)
- (when ep
- (setf (functional-kind ep) :optional)
- (setf (leaf-ever-used ep) t)
- (setf (lambda-optional-dispatch ep) res))))
- (dolist (ep (optional-dispatch-entry-points res)) (frob ep))
- (frob (optional-dispatch-more-entry res))
- (frob (optional-dispatch-main-entry res)))
-
res))
;;; Convert a LAMBDA form into a LAMBDA leaf or an OPTIONAL-DISPATCH leaf.
@@ -1035,3 +1079,15 @@
(specifier-type 'function))))
(values))
+
+
+;;; Entry point utilities
+
+;;; Return a function for the Nth entry point.
+(defun optional-dispatch-entry-point-fun (dispatcher n)
+ (declare (type optional-dispatch dispatcher)
+ (type unsigned-byte n))
+ (let* ((env (getf (optional-dispatch-plist dispatcher) :ir1-environment))
+ (*lexenv* (first env))
+ (*current-path* (second env)))
+ (force (nth n (optional-dispatch-entry-points dispatcher)))))
Index: ir1tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1tran.lisp,v
retrieving revision 1.106
retrieving revision 1.107
diff -u -d -r1.106 -r1.107
--- ir1tran.lisp 4 Jun 2003 05:58:18 -0000 1.106
+++ ir1tran.lisp 4 Jun 2003 06:03:12 -0000 1.107
@@ -550,6 +550,10 @@
(when (and functional
(not (functional-kind functional)))
(maybe-reanalyze-functional functional))))
+ (when (and (lambda-p leaf)
+ (memq (functional-kind leaf)
+ '(nil :optional)))
+ (maybe-reanalyze-functional leaf))
leaf))
(ref (make-ref leaf)))
(push ref (leaf-refs leaf))
Index: ir1util.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1util.lisp,v
retrieving revision 1.60
retrieving revision 1.61
diff -u -d -r1.60 -r1.61
--- ir1util.lisp 26 May 2003 04:25:55 -0000 1.60
+++ ir1util.lisp 4 Jun 2003 06:03:12 -0000 1.61
@@ -510,10 +510,16 @@
(defun continuation-single-value-p (cont)
(let ((dest (continuation-dest cont)))
(typecase dest
- ((or creturn exit cast)
+ ((or creturn exit)
nil)
(mv-combination
(eq (basic-combination-fun dest) cont))
+ (cast
+ #+nil
+ (locally
+ (declare (notinline continuation-single-value-p))
+ (and (not (values-type-p (cast-asserted-type dest)))
+ (continuation-single-value-p (node-cont dest)))))
(t
t))))
@@ -911,7 +917,8 @@
(maybe-convert-to-assignment fun)))))))
(dolist (ep (optional-dispatch-entry-points leaf))
- (frob ep))
+ (when (promise-ready-p ep)
+ (frob (force ep))))
(when (optional-dispatch-more-entry leaf)
(frob (optional-dispatch-more-entry leaf)))
(let ((main (optional-dispatch-main-entry leaf)))
Index: locall.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/locall.lisp,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -d -r1.47 -r1.48
--- locall.lisp 26 May 2003 08:17:16 -0000 1.47
+++ locall.lisp 4 Jun 2003 06:03:13 -0000 1.48
@@ -144,11 +144,12 @@
(n-supplied (gensym))
(temps (make-gensym-list max)))
(collect ((entries))
- (do ((eps (optional-dispatch-entry-points fun) (rest eps))
- (n min (1+ n)))
- ((null eps))
- (entries `((= ,n-supplied ,n)
- (%funcall ,(first eps) ,@(subseq temps 0 n)))))
+ ;; Force convertion of all entries
+ (optional-dispatch-entry-point-fun fun 0)
+ (loop for ep in (optional-dispatch-entry-points fun)
+ and n from min
+ do (entries `((= ,n-supplied ,n)
+ (%funcall ,(force ep) ,@(subseq temps 0 n)))))
`(lambda (,n-supplied ,@temps)
;; FIXME: Make sure that INDEX type distinguishes between
;; target and host. (Probably just make the SB!XC:DEFTYPE
@@ -173,7 +174,7 @@
;;; then associate this lambda with FUN as its XEP. After the
;;; conversion, we iterate over the function's associated lambdas,
;;; redoing local call analysis so that the XEP calls will get
-;;; converted.
+;;; converted.
;;;
;;; We set REANALYZE and REOPTIMIZE in the component, just in case we
;;; discover an XEP after the initial local call analyze pass.
@@ -196,7 +197,7 @@
(locall-analyze-fun-1 fun))
(optional-dispatch
(dolist (ep (optional-dispatch-entry-points fun))
- (locall-analyze-fun-1 ep))
+ (locall-analyze-fun-1 (force ep)))
(when (optional-dispatch-more-entry fun)
(locall-analyze-fun-1 (optional-dispatch-more-entry fun)))))
res)))
@@ -315,7 +316,8 @@
;; COMPONENT is the only one here. Let's make that explicit.
(aver (= 1 (length (functional-components clambda))))
(aver (eql component (first (functional-components clambda))))
- (when (component-new-functionals component)
+ (when (or (component-new-functionals component)
+ (component-reanalyze-functionals component))
(setf did-something t)
(locall-analyze-component component))))
(unless did-something
@@ -431,7 +433,10 @@
(not (functional-entry-fun fun))
(= (length (leaf-refs fun)) 1)
(= (length (basic-combination-args call)) 1))
- (let ((ep (car (last (optional-dispatch-entry-points fun)))))
+ (let* ((*current-component* (node-component ref))
+ (ep (optional-dispatch-entry-point-fun
+ fun (optional-dispatch-max-args fun))))
+ (aver (= (optional-dispatch-min-args fun) 0))
(setf (basic-combination-kind call) :local)
(pushnew ep (lambda-calls-or-closes (node-home-lambda call)))
(merge-tail-sets call ep)
@@ -498,8 +503,9 @@
(setf (basic-combination-kind call) :error))
((<= call-args max-args)
(convert-call ref call
- (elt (optional-dispatch-entry-points fun)
- (- call-args min-args))))
+ (let ((*current-component* (node-component ref)))
+ (optional-dispatch-entry-point-fun
+ fun (- call-args min-args)))))
((optional-dispatch-more-entry fun)
(convert-more-call ref call fun))
(t
Index: main.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/main.lisp,v
retrieving revision 1.71
retrieving revision 1.72
diff -u -d -r1.71 -r1.72
--- main.lisp 26 May 2003 04:25:56 -0000 1.71
+++ main.lisp 4 Jun 2003 06:03:13 -0000 1.72
@@ -863,15 +863,16 @@
(etypecase f
(clambda (list (lambda-component f)))
(optional-dispatch (let ((result nil))
- (labels ((frob (clambda)
- (pushnew (lambda-component clambda)
- result))
- (maybe-frob (maybe-clambda)
- (when maybe-clambda
- (frob maybe-clambda))))
- (mapc #'frob (optional-dispatch-entry-points f))
+ (flet ((maybe-frob (maybe-clambda)
+ (when (and maybe-clambda
+ (promise-ready-p maybe-clambda))
+ (pushnew (lambda-component
+ (force maybe-clambda))
+ result))))
+ (map nil #'maybe-frob (optional-dispatch-entry-points f))
(maybe-frob (optional-dispatch-more-entry f))
- (maybe-frob (optional-dispatch-main-entry f)))))))
+ (maybe-frob (optional-dispatch-main-entry f)))
+ result))))
(defun make-functional-from-toplevel-lambda (definition
&key
Index: node.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/node.lisp,v
retrieving revision 1.40
retrieving revision 1.41
diff -u -d -r1.40 -r1.41
--- node.lisp 26 May 2003 04:25:56 -0000 1.40
+++ node.lisp 4 Jun 2003 06:03:13 -0000 1.41
@@ -995,10 +995,10 @@
;; the total number of required and optional arguments. Args at
;; positions >= to this are &REST, &KEY or illegal args.
(max-args 0 :type unsigned-byte)
- ;; list of the LAMBDAs which are the entry points for non-rest,
- ;; non-key calls. The entry for MIN-ARGS is first, MIN-ARGS+1
- ;; second, ... MAX-ARGS last. The last entry-point always calls the
- ;; main entry; in simple cases it may be the main entry.
+ ;; list of the (maybe delayed) LAMBDAs which are the entry points
+ ;; for non-rest, non-key calls. The entry for MIN-ARGS is first,
+ ;; MIN-ARGS+1 second, ... MAX-ARGS last. The last entry-point always
+ ;; calls the main entry; in simple cases it may be the main entry.
(entry-points nil :type list)
;; an entry point which takes MAX-ARGS fixed arguments followed by
;; an argument context pointer and an argument count. This entry
|