X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Flocall.lisp;h=0257739250b227ab7c02bede0b3823a22e26c447;hb=a74b0bdb483504f6faddf8089f848f61ed94b92a;hp=ef4fc530cc3e66f2dc8f138605194aafa16e6b61;hpb=3d9e0f7398c7824e328345baa7e81c36aa49f106;p=sbcl.git diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index ef4fc53..0257739 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -40,7 +40,8 @@ (let ((arg (car args)) (var (car vars))) (cond ((leaf-refs var) - (assert-continuation-type arg (leaf-type var))) + (assert-continuation-type arg (leaf-type var) + (lexenv-policy (node-lexenv call)))) (t (flush-dest arg) (setf (car args) nil))))) @@ -133,21 +134,11 @@ (temps (make-gensym-list (length (lambda-vars fun))))) `(lambda (,n-supplied ,@temps) (declare (type index ,n-supplied)) - ,(if (policy *lexenv* (zerop safety)) + ,(if (policy *lexenv* (zerop verify-arg-count)) `(declare (ignore ,n-supplied)) `(%verify-arg-count ,n-supplied ,nargs)) (locally - ;; KLUDGE: The intent here is to enable tail recursion - ;; optimization, since leaving frames for wrapper - ;; functions like this on the stack is actually more - ;; annoying than helpful for debugging. Unfortunately - ;; trying to express this by messing with the - ;; ANSI-standard declarations is a little awkward, since - ;; no matter how we do it we'll tend to have side-effects - ;; on things like SPEED-vs.-SAFETY comparisons. Perhaps - ;; it'd be better to define a new SB-EXT:TAIL-RECURSIVELY - ;; declaration and use that? -- WHN 2002-07-08 - (declare (optimize (speed 2) (debug 1))) + (declare (optimize (merge-tail-calls 3))) (%funcall ,fun ,@temps))))) (optional-dispatch (let* ((min (optional-dispatch-min-args fun)) @@ -175,11 +166,7 @@ `(multiple-value-bind (,n-context ,n-count) (%more-arg-context ,n-supplied ,max) (locally - ;; KLUDGE: As above, we're trying to - ;; enable tail recursion optimization and - ;; any other effects of this declaration - ;; are accidental. -- WHN 2002-07-08 - (declare (optimize (speed 2) (debug 1))) + (declare (optimize (merge-tail-calls 3))) (%funcall ,more ,@temps ,n-context ,n-count))))))) (t (%arg-count-error ,n-supplied))))))))) @@ -456,7 +443,8 @@ (assert-continuation-type (first (basic-combination-args call)) (make-values-type :optional (mapcar #'leaf-type (lambda-vars ep)) - :rest *universal-type*)))) + :rest *universal-type*) + (lexenv-policy (node-lexenv call))))) (values)) ;;; Attempt to convert a call to a lambda. If the number of args is @@ -545,8 +533,8 @@ (with-ir1-environment-from-node call (ir1-convert-lambda `(lambda ,vars - (declare (ignorable . ,ignores)) - (%funcall ,entry . ,args)) + (declare (ignorable ,@ignores)) + (%funcall ,entry ,@args)) :debug-name (debug-namify "hairy function entry ~S" (continuation-fun-name (basic-combination-fun call))))))) @@ -779,10 +767,10 @@ ;; information. (setf (tail-set-info (lambda-tail-set clambda)) nil)) -;;; Handle the environment semantics of LET conversion. We add CLAMBDA -;;; and its LETs to LETs for the CALL's home function. We merge the -;;; calls for CLAMBDA with the calls for the home function, removing -;;; CLAMBDA in the process. We also merge the ENTRIES. +;;; Handle the PHYSENV semantics of LET conversion. We add CLAMBDA and +;;; its LETs to LETs for the CALL's home function. We merge the calls +;;; for CLAMBDA with the calls for the home function, removing CLAMBDA +;;; in the process. We also merge the ENTRIES. ;;; ;;; We also unlink the function head from the component head and set ;;; COMPONENT-REANALYZE to true to indicate that the DFO should be @@ -801,20 +789,20 @@ (depart-from-tail-set clambda) (let* ((home (node-home-lambda call)) - (home-env (lambda-physenv home))) + (home-physenv (lambda-physenv home))) (aver (not (eq home clambda))) ;; CLAMBDA belongs to HOME now. (push clambda (lambda-lets home)) (setf (lambda-home clambda) home) - (setf (lambda-physenv clambda) home-env) + (setf (lambda-physenv clambda) home-physenv) ;; All of CLAMBDA's LETs belong to HOME now. (let ((lets (lambda-lets clambda))) (dolist (let lets) (setf (lambda-home let) home) - (setf (lambda-physenv let) home-env)) + (setf (lambda-physenv let) home-physenv)) (setf (lambda-lets home) (nconc lets (lambda-lets home)))) ;; CLAMBDA no longer has an independent existence as an entity ;; which has LETs. @@ -867,7 +855,10 @@ (cont (node-cont call)) (call-type (node-derived-type call))) (when (eq (continuation-use cont) call) - (assert-continuation-type cont (continuation-asserted-type result))) + (set-continuation-type-assertion + cont + (continuation-asserted-type result) + (continuation-type-to-check result))) (unless (eq call-type *wild-type*) (do-uses (use result) (derive-node-type use call-type))) @@ -991,15 +982,16 @@ ;; From the user's point of view, LET-converting something that ;; has a name is inlining it. (The user can't see what we're doing ;; with anonymous things, and suppressing inlining - ;; for such things can easily give Python acute indigestion, so + ;; for such things can easily give Python acute indigestion, so ;; we don't.) (when (leaf-has-source-name-p clambda) ;; ANSI requires that explicit NOTINLINE be respected. (or (eq (lambda-inlinep clambda) :notinline) - ;; If (> DEBUG SPEED) we can guess that inlining generally - ;; won't be appreciated, but if the user specifically requests - ;; inlining, that takes precedence over our general guess. - (and (policy clambda (> debug speed)) + ;; If (= LET-CONVERTION 0) we can guess that inlining + ;; generally won't be appreciated, but if the user + ;; specifically requests inlining, that takes precedence over + ;; our general guess. + (and (policy clambda (= let-convertion 0)) (not (eq (lambda-inlinep clambda) :inline)))))) ;;; We also don't convert calls to named functions which appear in the