;;; continuations.
(defun propagate-to-args (call fun)
(declare (type combination call) (type clambda fun))
- (do ((args (basic-combination-args call) (cdr args))
- (vars (lambda-vars fun) (cdr vars)))
- ((null args))
- (let ((arg (car args))
- (var (car vars)))
- (cond ((leaf-refs var)
- (assert-continuation-type arg (leaf-type var)
- (lexenv-policy (node-lexenv call))))
- (t
- (flush-dest arg)
- (setf (car args) nil)))))
+ (loop with policy = (lexenv-policy (node-lexenv call))
+ for args on (basic-combination-args call)
+ and var in (lambda-vars fun)
+ for arg = (assert-continuation-type (car args)
+ (leaf-type var) policy)
+ do (unless (leaf-refs var)
+ (flush-dest (car args))
+ (setf (car args) nil)))
(values))
;;;
;;; If there is a &MORE arg, then there are a couple of optimizations
;;; that we make (more for space than anything else):
-;;; -- If MIN-ARGS is 0, then we make the more entry a T clause, since
+;;; -- If MIN-ARGS is 0, then we make the more entry a T clause, since
;;; no argument count error is possible.
-;;; -- We can omit the = clause for the last entry-point, allowing the
+;;; -- We can omit the = clause for the last entry-point, allowing the
;;; case of 0 more args to fall through to the more entry.
;;;
;;; We don't bother to policy conditionalize wrong arg errors in
(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
original-functional)))))))
(cond (losing-local-functional
(let ((*compiler-error-context* call))
- (compiler-note "couldn't inline expand because expansion ~
- calls this LET-converted local function:~
- ~% ~S"
+ (compiler-notify "couldn't inline expand because expansion ~
+ calls this LET-converted local function:~
+ ~% ~S"
(leaf-debug-name losing-local-functional)))
original-functional)
(t
(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)
(assert-continuation-type
(first (basic-combination-args call))
- (make-values-type :optional (mapcar #'leaf-type (lambda-vars ep))
- :rest *universal-type*)
+ (make-short-values-type (mapcar #'leaf-type (lambda-vars ep)))
(lexenv-policy (node-lexenv call)))))
(values))
(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
(let ((cont (first key)))
(unless (constant-continuation-p cont)
(when flame
- (compiler-note "non-constant keyword in keyword call"))
+ (compiler-notify "non-constant keyword in keyword call"))
(setf (basic-combination-kind call) :error)
(return-from convert-more-call))
(setq allow-found t
allowp (continuation-value val)))
(t (when flame
- (compiler-note "non-constant :ALLOW-OTHER-KEYS value"))
+ (compiler-notify "non-constant :ALLOW-OTHER-KEYS value"))
(setf (basic-combination-kind call) :error)
(return-from convert-more-call)))))
(dolist (var (key-vars)
(collect ((call-args))
(do ((var arglist (cdr var))
(temp temps (cdr temp)))
- (())
+ ((null var))
(let ((info (lambda-var-arg-info (car var))))
(if info
(ecase (arg-info-kind info)
(join-components component clambda-component)))
(let ((*current-component* component))
(node-ends-block call))
- ;; FIXME: Use DESTRUCTURING-BIND here, and grep for other
+ ;; FIXME: Use DESTRUCTURING-BIND here, and grep for other
;; uses of '=.*length' which could also be converted to use
;; DESTRUCTURING-BIND or PROPER-LIST-OF-LENGTH-P.
(aver (= (length (block-succ call-block)) 1))
;;; node, and change the control flow to transfer to NEXT-BLOCK
;;; instead. Move all the uses of the result continuation to CALL's
;;; CONT.
-;;;
-;;; If the actual continuation is only used by the LET call, then we
-;;; intersect the type assertion on the dummy continuation with the
-;;; assertion for the actual continuation; in all other cases
-;;; assertions on the dummy continuation are lost.
-;;;
-;;; We also intersect the derived type of the CALL with the derived
-;;; type of all the dummy continuation's uses. This serves mainly to
-;;; propagate TRULY-THE through LETs.
(defun move-return-uses (fun call next-block)
(declare (type clambda fun) (type basic-combination call)
(type cblock next-block))
(let ((result (return-result return))
(cont (node-cont call))
(call-type (node-derived-type call)))
- (when (eq (continuation-use cont) call)
- (set-continuation-type-assertion
- cont
- (continuation-asserted-type result)
- (continuation-type-to-check result)))
(unless (eq call-type *wild-type*)
- (do-uses (use result)
+ ;; FIXME: Replace the call with unsafe CAST. -- APD, 2002-01-26
+ (do-uses (use result)
(derive-node-type use call-type)))
(substitute-continuation-uses cont result)))
(values))
(delete-continuation-use call)
(add-continuation-use call (return-result call-return)))
(move-return-uses fun call
- (or next-block (node-block call-return)))))
+ (or next-block
+ (let ((block (node-block call-return)))
+ (when (block-delete-p block)
+ (setf (block-delete-p block) nil))
+ block)))))
(t
(aver (node-tail-p call))
(setf (lambda-return call-fun) return)
projects / sbcl.git / blobdiff