;;; 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)
;;; 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)
;;; 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
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
,@(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))
;;; 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)
(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
(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)
(cons arg entry-vars)
(cons arg-name entry-vals)
(rest vars) supplied-p-p body aux-vars aux-vals cont
- source-name debug-name))))
-
- (convert-optional-entry ep default-vars default-vals
- (if supplied-p
- (list (arg-info-default info) nil)
- (list (arg-info-default info))))))
+ source-name debug-name
+ force))))
+
+ ;; 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
(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))
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)))
;;; 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)
(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)))
(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))
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
: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.
(specifier-type 'function))))
(values))
+
+\f
+;;; 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)))))
(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
;;; 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.
(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)))
;; 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
(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)
(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
projects / sbcl.git / commitdiff