(defun recognize-dynamic-extent-lvars (call fun)
(declare (type combination call) (type clambda fun))
(loop for arg in (basic-combination-args call)
(defun recognize-dynamic-extent-lvars (call fun)
(declare (type combination call) (type clambda fun))
(loop for arg in (basic-combination-args call)
- and var in (lambda-vars fun)
- when (and arg
- (lambda-var-dynamic-extent var)
- (not (lvar-dynamic-extent arg)))
- collect arg into dx-lvars
- and do (let ((use (lvar-uses arg)))
- ;; Stack analysis wants DX value generators to end
- ;; their blocks. Uses of mupltiple used LVARs already
- ;; end their blocks, so we just need to process
- ;; used-once LVARs.
- (when (node-p use)
- (node-ends-block use)))
+ for var in (lambda-vars fun)
+ for dx = (lambda-var-dynamic-extent var)
+ when (and dx arg (not (lvar-dynamic-extent arg)))
+ append (handle-nested-dynamic-extent-lvars dx arg) into dx-lvars
- (binding* ((before-ctran (node-prev call))
- (nil (ensure-block-start before-ctran))
- (block (ctran-block before-ctran))
- (new-call-ctran (make-ctran :kind :inside-block
- :next call
- :block block))
- (entry (with-ir1-environment-from-node call
- (make-entry :prev before-ctran
- :next new-call-ctran)))
- (cleanup (make-cleanup :kind :dynamic-extent
- :mess-up entry
- :info dx-lvars)))
- (setf (node-prev call) new-call-ctran)
- (setf (ctran-next before-ctran) entry)
- (setf (ctran-use new-call-ctran) entry)
+ ;; Stack analysis requires that the CALL ends the block, so
+ ;; that MAP-BLOCK-NLXES sees the cleanup we insert here.
+ (node-ends-block call)
+ (let* ((entry (with-ir1-environment-from-node call
+ (make-entry)))
+ (cleanup (make-cleanup :kind :dynamic-extent
+ :mess-up entry
+ :info dx-lvars)))
- (fun-set (lambda-tail-set new-fun)))
- (unless (eq call-set fun-set)
- (let ((funs (tail-set-funs fun-set)))
- (dolist (fun funs)
- (setf (lambda-tail-set fun) call-set))
- (setf (tail-set-funs call-set)
- (nconc (tail-set-funs call-set) funs)))
- (reoptimize-lvar (return-result return))
- t)))))
+ (fun-set (lambda-tail-set new-fun)))
+ (unless (eq call-set fun-set)
+ (let ((funs (tail-set-funs fun-set)))
+ (dolist (fun funs)
+ (setf (lambda-tail-set fun) call-set))
+ (setf (tail-set-funs call-set)
+ (nconc (tail-set-funs call-set) funs)))
+ (reoptimize-lvar (return-result return))
+ t)))))
;;; Convert a combination into a local call. We PROPAGATE-TO-ARGS, set
;;; the combination kind to :LOCAL, add FUN to the CALLS of the
;;; Convert a combination into a local call. We PROPAGATE-TO-ARGS, set
;;; the combination kind to :LOCAL, add FUN to the CALLS of the
(recognize-dynamic-extent-lvars call fun)
(merge-tail-sets call fun)
(change-ref-leaf ref fun)
(recognize-dynamic-extent-lvars call fun)
(merge-tail-sets call fun)
(change-ref-leaf ref fun)
- (declare (type index ,n-supplied))
- ,(if (policy *lexenv* (zerop verify-arg-count))
- `(declare (ignore ,n-supplied))
- `(%verify-arg-count ,n-supplied ,nargs))
- (locally
- (declare (optimize (merge-tail-calls 3)))
- (%funcall ,fun ,@temps)))))
+ (declare (type index ,n-supplied))
+ ,(if (policy *lexenv* (zerop verify-arg-count))
+ `(declare (ignore ,n-supplied))
+ `(%verify-arg-count ,n-supplied ,nargs))
+ (locally
+ (declare (optimize (merge-tail-calls 3)))
+ (%funcall ,fun ,@temps)))))
- (max (optional-dispatch-max-args fun))
- (more (optional-dispatch-more-entry fun))
- (n-supplied (gensym))
- (temps (make-gensym-list max)))
+ (max (optional-dispatch-max-args fun))
+ (more (optional-dispatch-more-entry fun))
+ (n-supplied (gensym))
+ (temps (make-gensym-list max)))
- `(lambda (,n-supplied ,@temps)
- ;; FIXME: Make sure that INDEX type distinguishes between
- ;; target and host. (Probably just make the SB!XC:DEFTYPE
- ;; different from CL:DEFTYPE.)
- (declare (type index ,n-supplied))
- (cond
- ,@(if more (butlast (entries)) (entries))
- ,@(when more
- `((,(if (zerop min) t `(>= ,n-supplied ,max))
- ,(let ((n-context (gensym))
- (n-count (gensym)))
- `(multiple-value-bind (,n-context ,n-count)
- (%more-arg-context ,n-supplied ,max)
- (locally
- (declare (optimize (merge-tail-calls 3)))
- (%funcall ,more ,@temps ,n-context ,n-count)))))))
- (t
- (%arg-count-error ,n-supplied)))))))))
+ `(lambda (,n-supplied ,@temps)
+ (declare (type index ,n-supplied))
+ (cond
+ ,@(if more (butlast (entries)) (entries))
+ ,@(when more
+ ;; KLUDGE: (NOT (< ...)) instead of >= avoids one round of
+ ;; deftransforms and lambda-conversion.
+ `((,(if (zerop min) t `(not (< ,n-supplied ,max)))
+ ,(with-unique-names (n-context n-count)
+ `(multiple-value-bind (,n-context ,n-count)
+ (%more-arg-context ,n-supplied ,max)
+ (locally
+ (declare (optimize (merge-tail-calls 3)))
+ (%funcall ,more ,@temps ,n-context ,n-count)))))))
+ (t
+ (%arg-count-error ,n-supplied)))))))))
(declare (type functional fun))
(aver (null (functional-entry-fun fun)))
(with-ir1-environment-from-node (lambda-bind (main-entry fun))
(declare (type functional fun))
(aver (null (functional-entry-fun fun)))
(with-ir1-environment-from-node (lambda-bind (main-entry fun))
- (let ((res (ir1-convert-lambda (make-xep-lambda-expression fun)
- :debug-name (debug-namify
- "XEP for "
- (leaf-debug-name fun)))))
- (setf (functional-kind res) :external
- (leaf-ever-used res) t
- (functional-entry-fun res) fun
- (functional-entry-fun fun) res
- (component-reanalyze *current-component*) t
- (component-reoptimize *current-component*) t)
- (etypecase fun
- (clambda
- (locall-analyze-fun-1 fun))
- (optional-dispatch
- (dolist (ep (optional-dispatch-entry-points fun))
- (locall-analyze-fun-1 (force ep)))
- (when (optional-dispatch-more-entry fun)
- (locall-analyze-fun-1 (optional-dispatch-more-entry fun)))))
- res)))
+ (let ((xep (ir1-convert-lambda (make-xep-lambda-expression fun)
+ :debug-name (debug-name
+ 'xep (leaf-debug-name fun))
+ :system-lambda t)))
+ (setf (functional-kind xep) :external
+ (leaf-ever-used xep) t
+ (functional-entry-fun xep) fun
+ (functional-entry-fun fun) xep
+ (component-reanalyze *current-component*) t)
+ (reoptimize-component *current-component* :maybe)
+ (locall-analyze-xep-entry-point fun)
+ xep)))
+
+(defun locall-analyze-xep-entry-point (fun)
+ (declare (type functional fun))
+ (etypecase fun
+ (clambda
+ (locall-analyze-fun-1 fun))
+ (optional-dispatch
+ (dolist (ep (optional-dispatch-entry-points fun))
+ (locall-analyze-fun-1 (force ep)))
+ (when (optional-dispatch-more-entry fun)
+ (locall-analyze-fun-1 (optional-dispatch-more-entry fun))))))
;;; Notice a REF that is not in a local-call context. If the REF is
;;; already to an XEP, then do nothing, otherwise change it to the
;;; Notice a REF that is not in a local-call context. If the REF is
;;; already to an XEP, then do nothing, otherwise change it to the
;;; do LET conversion here.
(defun locall-analyze-fun-1 (fun)
(declare (type functional fun))
;;; do LET conversion here.
(defun locall-analyze-fun-1 (fun)
(declare (type functional fun))
(unless (node-to-be-deleted-p ref)
(cond ((and (basic-combination-p dest)
(eq (basic-combination-fun dest) lvar)
(unless (node-to-be-deleted-p ref)
(cond ((and (basic-combination-p dest)
(eq (basic-combination-fun dest) lvar)
- (cond ((or (functional-somewhat-letlike-p functional)
- (memq kind '(:deleted :zombie)))
- (values)) ; nothing to do
- ((and (null (leaf-refs functional)) (eq kind nil)
- (not (functional-entry-fun functional)))
- (delete-functional functional))
- (t
- ;; Fix/check FUNCTIONAL's relationship to COMPONENT-LAMDBAS.
- (cond ((not (lambda-p functional))
- ;; Since FUNCTIONAL isn't a LAMBDA, this doesn't
- ;; apply: no-op.
- (values))
- (new-functional ; FUNCTIONAL came from
- ; NEW-FUNCTIONALS, hence is new.
- ;; FUNCTIONAL becomes part of COMPONENT-LAMBDAS now.
- (aver (not (member functional
- (component-lambdas component))))
- (push functional (component-lambdas component)))
- (t ; FUNCTIONAL is old.
- ;; FUNCTIONAL should be in COMPONENT-LAMBDAS already.
- (aver (member functional (component-lambdas
- component)))))
- (locall-analyze-fun-1 functional)
- (when (lambda-p functional)
- (maybe-let-convert functional)))))))
+ (cond ((or (functional-somewhat-letlike-p functional)
+ (memq kind '(:deleted :zombie)))
+ (values)) ; nothing to do
+ ((and (null (leaf-refs functional)) (eq kind nil)
+ (not (functional-entry-fun functional)))
+ (delete-functional functional))
+ (t
+ ;; Fix/check FUNCTIONAL's relationship to COMPONENT-LAMDBAS.
+ (cond ((not (lambda-p functional))
+ ;; Since FUNCTIONAL isn't a LAMBDA, this doesn't
+ ;; apply: no-op.
+ (values))
+ (new-functional ; FUNCTIONAL came from
+ ; NEW-FUNCTIONALS, hence is new.
+ ;; FUNCTIONAL becomes part of COMPONENT-LAMBDAS now.
+ (aver (not (member functional
+ (component-lambdas component))))
+ (push functional (component-lambdas component)))
+ (t ; FUNCTIONAL is old.
+ ;; FUNCTIONAL should be in COMPONENT-LAMBDAS already.
+ (aver (member functional (component-lambdas
+ component)))))
+ (locall-analyze-fun-1 functional)
+ (when (lambda-p functional)
+ (maybe-let-convert functional)))))))
(values))
(defun locall-analyze-clambdas-until-done (clambdas)
(loop
(let ((did-something nil))
(dolist (clambda clambdas)
(values))
(defun locall-analyze-clambdas-until-done (clambdas)
(loop
(let ((did-something nil))
(dolist (clambda clambdas)
- (let* ((component (lambda-component clambda))
- (*all-components* (list component)))
- ;; The original CMU CL code seemed to implicitly assume that
- ;; 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 (or (component-new-functionals component)
+ (let ((component (lambda-component clambda)))
+ ;; The original CMU CL code seemed to implicitly assume that
+ ;; 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 (or (component-new-functionals component)
- (and (>= speed space)
- (>= speed compilation-speed)))
- (not (eq (functional-kind (node-home-lambda call)) :external))
- (inline-expansion-ok call))
+ (and (>= speed space)
+ (>= speed compilation-speed)))
+ (not (eq (functional-kind (node-home-lambda call)) :external))
+ (inline-expansion-ok call))
(catch 'locall-already-let-converted
(with-ir1-environment-from-node call
(let ((*lexenv* (functional-lexenv original-functional)))
(values nil
(ir1-convert-lambda
(functional-inline-expansion original-functional)
(catch 'locall-already-let-converted
(with-ir1-environment-from-node call
(let ((*lexenv* (functional-lexenv original-functional)))
(values nil
(ir1-convert-lambda
(functional-inline-expansion original-functional)
- :debug-name (debug-namify
- "local inline "
- (leaf-debug-name
- original-functional)))))))
- (cond (losing-local-functional
- (let ((*compiler-error-context* call))
- (compiler-notify "couldn't inline expand because expansion ~
- calls this LET-converted local function:~
- ~% ~S"
- (leaf-debug-name losing-local-functional)))
+ :debug-name (debug-name 'local-inline
+ (leaf-debug-name
+ original-functional)))))))
+ (cond (losing-local-object
+ (if (functional-p losing-local-object)
+ (let ((*compiler-error-context* call))
+ (compiler-notify "couldn't inline expand because expansion ~
+ calls this LET-converted local function:~
+ ~% ~S"
+ (leaf-debug-name losing-local-object)))
+ (let ((*compiler-error-context* call))
+ (compiler-notify "implementation limitation: couldn't inline ~
+ expand because expansion refers to ~
+ the optimized away object ~S."
+ losing-local-object)))
(defun convert-call-if-possible (ref call)
(declare (type ref ref) (type basic-combination call))
(let* ((block (node-block call))
(defun convert-call-if-possible (ref call)
(declare (type ref ref) (type basic-combination call))
(let* ((block (node-block call))
(aver (functional-p original-fun))
(unless (or (member (basic-combination-kind call) '(:local :error))
(node-to-be-deleted-p call)
(aver (functional-p original-fun))
(unless (or (member (basic-combination-kind call) '(:local :error))
(node-to-be-deleted-p call)
- (member (functional-kind original-fun)
- '(:toplevel-xep :deleted))
- (not (or (eq (component-kind component) :initial)
- (eq (block-component
- (node-block
- (lambda-bind (main-entry original-fun))))
- component))))
+ (member (functional-kind original-fun)
+ '(:toplevel-xep :deleted))
+ (not (or (eq (component-kind component) :initial)
+ (eq (block-component
+ (node-block
+ (lambda-bind (main-entry original-fun))))
+ component))))
- (when (and (eq (functional-inlinep fun) :inline)
- (rest (leaf-refs original-fun)))
- (setq fun (maybe-expand-local-inline fun ref call)))
+ (when (and (eq (functional-inlinep fun) :inline)
+ (rest (leaf-refs original-fun)))
+ (setq fun (maybe-expand-local-inline fun ref call)))
- (aver (member (functional-kind fun)
- '(nil :escape :cleanup :optional)))
- (cond ((mv-combination-p call)
- (convert-mv-call ref call fun))
- ((lambda-p fun)
- (convert-lambda-call ref call fun))
- (t
- (convert-hairy-call ref call fun))))))
+ (aver (member (functional-kind fun)
+ '(nil :escape :cleanup :optional)))
+ (cond ((mv-combination-p call)
+ (convert-mv-call ref call fun))
+ ((lambda-p fun)
+ (convert-lambda-call ref call fun))
+ (t
+ (convert-hairy-call ref call fun))))))
(defun convert-mv-call (ref call fun)
(declare (type ref ref) (type mv-combination call) (type functional fun))
(when (and (looks-like-an-mv-bind fun)
(defun convert-mv-call (ref call fun)
(declare (type ref ref) (type mv-combination call) (type functional fun))
(when (and (looks-like-an-mv-bind fun)
(let* ((*current-component* (node-component ref))
(ep (optional-dispatch-entry-point-fun
fun (optional-dispatch-max-args fun))))
(when (null (leaf-refs ep))
(aver (= (optional-dispatch-min-args fun) 0))
(let* ((*current-component* (node-component ref))
(ep (optional-dispatch-entry-point-fun
fun (optional-dispatch-max-args fun))))
(when (null (leaf-refs ep))
(aver (= (optional-dispatch-min-args fun) 0))
(defun convert-lambda-call (ref call fun)
(declare (type ref ref) (type combination call) (type clambda fun))
(let ((nargs (length (lambda-vars fun)))
(defun convert-lambda-call (ref call fun)
(declare (type ref ref) (type combination call) (type clambda fun))
(let ((nargs (length (lambda-vars fun)))
- (convert-call ref call fun))
- (t
- (warn
- 'local-argument-mismatch
- :format-control
- "function called with ~R argument~:P, but wants exactly ~R"
- :format-arguments (list n-call-args nargs))
- (setf (basic-combination-kind call) :error)))))
+ (convert-call ref call fun))
+ (t
+ (warn
+ 'local-argument-mismatch
+ :format-control
+ "function called with ~R argument~:P, but wants exactly ~R"
+ :format-arguments (list n-call-args nargs))
+ (setf (basic-combination-kind call) :error)))))
;;; that have a &MORE (or &REST) arg.
(defun convert-hairy-call (ref call fun)
(declare (type ref ref) (type combination call)
;;; that have a &MORE (or &REST) arg.
(defun convert-hairy-call (ref call fun)
(declare (type ref ref) (type combination call)
- (warn
- 'local-argument-mismatch
- :format-control
- "function called with ~R argument~:P, but wants at least ~R"
- :format-arguments (list call-args min-args))
- (setf (basic-combination-kind call) :error))
- ((<= call-args max-args)
- (convert-call ref call
+ (warn
+ 'local-argument-mismatch
+ :format-control
+ "function called with ~R argument~:P, but wants at least ~R"
+ :format-arguments (list call-args min-args))
+ (setf (basic-combination-kind call) :error))
+ ((<= call-args max-args)
+ (convert-call ref call
(let ((*current-component* (node-component ref)))
(optional-dispatch-entry-point-fun
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
- (warn
- 'local-argument-mismatch
- :format-control
- "function called with ~R argument~:P, but wants at most ~R"
- :format-arguments
- (list call-args max-args))
- (setf (basic-combination-kind call) :error))))
+ ((optional-dispatch-more-entry fun)
+ (convert-more-call ref call fun))
+ (t
+ (warn
+ 'local-argument-mismatch
+ :format-control
+ "function called with ~R argument~:P, but wants at most ~R"
+ :format-arguments
+ (list call-args max-args))
+ (setf (basic-combination-kind call) :error))))
;;; that everything gets converted during the single pass.
(defun convert-hairy-fun-entry (ref call entry vars ignores args)
(declare (list vars ignores args) (type ref ref) (type combination call)
;;; that everything gets converted during the single pass.
(defun convert-hairy-fun-entry (ref call entry vars ignores args)
(declare (list vars ignores args) (type ref ref) (type combination call)
- (with-ir1-environment-from-node call
- (ir1-convert-lambda
- `(lambda ,vars
- (declare (ignorable ,@ignores))
- (%funcall ,entry ,@args))
- :debug-name (debug-namify "hairy function entry "
- (lvar-fun-name
- (basic-combination-fun call)))))))
+ (with-ir1-environment-from-node call
+ (ir1-convert-lambda
+ `(lambda ,vars
+ (declare (ignorable ,@ignores))
+ (%funcall ,entry ,@args))
+ :debug-name (debug-name 'hairy-function-entry
+ (lvar-fun-debug-name
+ (basic-combination-fun call)))
+ :system-lambda t))))
(convert-call ref call new-fun)
(dolist (ref (leaf-refs entry))
(convert-call-if-possible ref (lvar-dest (node-lvar ref))))))
(convert-call ref call new-fun)
(dolist (ref (leaf-refs entry))
(convert-call-if-possible ref (lvar-dest (node-lvar ref))))))
(defun convert-more-call (ref call fun)
(declare (type ref ref) (type combination call) (type optional-dispatch fun))
(let* ((max (optional-dispatch-max-args fun))
(defun convert-more-call (ref call fun)
(declare (type ref ref) (type combination call) (type optional-dispatch fun))
(let* ((max (optional-dispatch-max-args fun))
- (arglist (optional-dispatch-arglist fun))
- (args (combination-args call))
- (more (nthcdr max args))
- (flame (policy call (or (> speed inhibit-warnings)
- (> space inhibit-warnings))))
- (loser nil)
+ (arglist (optional-dispatch-arglist fun))
+ (args (combination-args call))
+ (more (nthcdr max args))
+ (flame (policy call (or (> speed inhibit-warnings)
+ (> space inhibit-warnings))))
+ (loser nil)
- (let ((info (lambda-var-arg-info var)))
- (when info
- (ecase (arg-info-kind info)
- (:keyword
- (key-vars var))
- ((:rest :optional))
- ((:more-context :more-count)
- (compiler-warn "can't local-call functions with &MORE args")
- (setf (basic-combination-kind call) :error)
- (return-from convert-more-call))))))
+ (let ((info (lambda-var-arg-info var)))
+ (when info
+ (ecase (arg-info-kind info)
+ (:keyword
+ (key-vars var))
+ ((:rest :optional))
+ ((:more-context :more-count)
+ (compiler-warn "can't local-call functions with &MORE args")
+ (setf (basic-combination-kind call) :error)
+ (return-from convert-more-call))))))
- (do ((key more (cddr key))
- (temp more-temps (cddr temp)))
- ((null key))
- (let ((lvar (first key)))
- (unless (constant-lvar-p lvar)
- (when flame
- (compiler-notify "non-constant keyword in keyword call"))
- (setf (basic-combination-kind call) :error)
- (return-from convert-more-call))
+ (do ((key more (cddr key))
+ (temp more-temps (cddr temp)))
+ ((null key))
+ (let ((lvar (first key)))
+ (unless (constant-lvar-p lvar)
+ (when flame
+ (compiler-notify "non-constant keyword in keyword call"))
+ (setf (basic-combination-kind call) :error)
+ (return-from convert-more-call))
(when (and (eq name :allow-other-keys) (not allow-found))
(let ((val (second key)))
(cond ((constant-lvar-p val)
(when (and (eq name :allow-other-keys) (not allow-found))
(let ((val (second key)))
(cond ((constant-lvar-p val)
(compiler-notify "non-constant :ALLOW-OTHER-KEYS value"))
(setf (basic-combination-kind call) :error)
(return-from convert-more-call)))))
(compiler-notify "non-constant :ALLOW-OTHER-KEYS value"))
(setf (basic-combination-kind call) :error)
(return-from convert-more-call)))))
- (let ((info (lambda-var-arg-info var)))
- (when (eq (arg-info-key info) name)
- (ignores dummy)
- (supplied (cons var val))
- (return)))))))
+ (let ((info (lambda-var-arg-info var)))
+ (when (eq (arg-info-key info) name)
+ (ignores dummy)
+ (if (member var (supplied) :key #'car)
+ (ignores val)
+ (supplied (cons var val)))
+ (return)))))))
- (when (and loser (not (optional-dispatch-allowp fun)) (not allowp))
- (compiler-warn "function called with unknown argument keyword ~S"
- (car loser))
- (setf (basic-combination-kind call) :error)
- (return-from convert-more-call)))
+ (when (and loser (not (optional-dispatch-allowp fun)) (not allowp))
+ (compiler-warn "function called with unknown argument keyword ~S"
+ (car loser))
+ (setf (basic-combination-kind call) :error)
+ (return-from convert-more-call)))
- (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)
- (:optional
- (call-args (car temp))
- (when (arg-info-supplied-p info)
- (call-args t)))
- (:rest
- (call-args `(list ,@more-temps))
- (return))
- (:keyword
- (return)))
- (call-args (car temp)))))
+ (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)
+ (:optional
+ (call-args (car temp))
+ (when (arg-info-supplied-p info)
+ (call-args t)))
+ (:rest
+ (call-args `(list ,@more-temps))
+ (return))
+ (:keyword
+ (return)))
+ (call-args (car temp)))))
- (dolist (var (key-vars))
- (let ((info (lambda-var-arg-info var))
- (temp (cdr (assoc var (supplied)))))
- (if temp
- (call-args temp)
- (call-args (arg-info-default info)))
- (when (arg-info-supplied-p info)
- (call-args (not (null temp))))))
+ (dolist (var (key-vars))
+ (let ((info (lambda-var-arg-info var))
+ (temp (cdr (assoc var (supplied)))))
+ (if temp
+ (call-args temp)
+ (call-args (arg-info-default info)))
+ (when (arg-info-supplied-p info)
+ (call-args (not (null temp))))))
- (convert-hairy-fun-entry ref call (optional-dispatch-main-entry fun)
- (append temps more-temps)
- (ignores) (call-args)))))
+ (convert-hairy-fun-entry ref call (optional-dispatch-main-entry fun)
+ (append temps more-temps)
+ (ignores) (call-args)))))
(defun insert-let-body (clambda call)
(declare (type clambda clambda) (type basic-combination call))
(let* ((call-block (node-block call))
(defun insert-let-body (clambda call)
(declare (type clambda clambda) (type basic-combination call))
(let* ((call-block (node-block call))
(aver-live-component component)
(let ((clambda-component (block-component bind-block)))
(unless (eq clambda-component component)
(aver-live-component component)
(let ((clambda-component (block-component bind-block)))
(unless (eq clambda-component component)
;; (LAMBDA-TAIL-SET CLAMBDA) here. Instead:
;; * If we're the only function in TAIL-SET-FUNS, it should
;; be safe to leave ourself linked to it, and it to you.
;; (LAMBDA-TAIL-SET CLAMBDA) here. Instead:
;; * If we're the only function in TAIL-SET-FUNS, it should
;; be safe to leave ourself linked to it, and it to you.
;; FINALIZE-XEP-DEFINITION) which might want to
;; know about our return type.
(let* ((old-tail-set (lambda-tail-set clambda))
;; FINALIZE-XEP-DEFINITION) which might want to
;; know about our return type.
(let* ((old-tail-set (lambda-tail-set clambda))
;; The documentation on TAIL-SET-INFO doesn't tell whether it could
;; remain valid in this case, so we nuke it on the theory that
;; missing information tends to be less dangerous than incorrect
;; The documentation on TAIL-SET-INFO doesn't tell whether it could
;; remain valid in this case, so we nuke it on the theory that
;; missing information tends to be less dangerous than incorrect
(let ((component (node-component call)))
(unlink-blocks (component-head component) (lambda-block clambda))
(setf (component-lambdas component)
(let ((component (node-component call)))
(unlink-blocks (component-head component) (lambda-block clambda))
(setf (component-lambdas component)
(setf (component-reanalyze component) t))
(setf (lambda-call-lexenv clambda) (node-lexenv call))
(depart-from-tail-set clambda)
(let* ((home (node-home-lambda call))
(setf (component-reanalyze component) t))
(setf (lambda-call-lexenv clambda) (node-lexenv call))
(depart-from-tail-set clambda)
(let* ((home (node-home-lambda call))
;; All of CLAMBDA's LETs belong to HOME now.
(let ((lets (lambda-lets clambda)))
(dolist (let lets)
(setf (lambda-home let) home)
;; All of CLAMBDA's LETs belong to HOME now.
(let ((lets (lambda-lets clambda)))
(dolist (let lets)
(setf (lambda-home let) home)
- (setf (lambda-calls-or-closes home)
- (delete clambda
- (nunion (lambda-calls-or-closes clambda)
- (lambda-calls-or-closes home))))
+ (sset-union (lambda-calls-or-closes home)
+ (lambda-calls-or-closes clambda))
+ (sset-delete clambda (lambda-calls-or-closes home))
;; CLAMBDA no longer has an independent existence as an entity
;; which calls things or has DFO dependencies.
(setf (lambda-calls-or-closes clambda) nil)
;; CLAMBDA no longer has an independent existence as an entity
;; which calls things or has DFO dependencies.
(setf (lambda-calls-or-closes clambda) nil)
;;; instead. Move all the uses of the result lvar to CALL's lvar.
(defun move-return-uses (fun call next-block)
(declare (type clambda fun) (type basic-combination call)
;;; instead. Move all the uses of the result lvar to CALL's lvar.
(defun move-return-uses (fun call next-block)
(declare (type clambda fun) (type basic-combination call)
- (let ((this-call (node-dest ref)))
- (when (and this-call
- (node-tail-p this-call)
- (eq (node-home-lambda this-call) fun))
- (setf (node-tail-p this-call) nil)
- (ecase (functional-kind called)
- ((nil :cleanup :optional)
- (let ((block (node-block this-call))
- (lvar (node-lvar call)))
- (unlink-blocks block (first (block-succ block)))
- (link-blocks block next-block)
+ (let ((this-call (node-dest ref)))
+ (when (and this-call
+ (node-tail-p this-call)
+ (eq (node-home-lambda this-call) fun))
+ (setf (node-tail-p this-call) nil)
+ (ecase (functional-kind called)
+ ((nil :cleanup :optional)
+ (let ((block (node-block this-call))
+ (lvar (node-lvar call)))
+ (unlink-blocks block (first (block-succ block)))
+ (link-blocks block next-block)
- (add-lvar-use this-call lvar)))
- (:deleted)
- ;; The called function might be an assignment in the
- ;; case where we are currently converting that function.
- ;; In steady-state, assignments never appear as a called
- ;; function.
- (:assignment
- (aver (eq called fun)))))))))
+ (add-lvar-use this-call lvar)))
+ (:deleted)
+ ;; The called function might be an assignment in the
+ ;; case where we are currently converting that function.
+ ;; In steady-state, assignments never appear as a called
+ ;; function.
+ (:assignment
+ (aver (eq called fun)))))))))
;;; move the return to the caller.
(defun move-return-stuff (fun call next-block)
(declare (type clambda fun) (type basic-combination call)
;;; move the return to the caller.
(defun move-return-stuff (fun call next-block)
(declare (type clambda fun) (type basic-combination call)
(when (and call-return
(block-delete-p (node-block call-return)))
(delete-return call-return)
(unlink-node call-return)
(setq call-return nil))
(cond ((not return))
(when (and call-return
(block-delete-p (node-block call-return)))
(delete-return call-return)
(unlink-node call-return)
(setq call-return nil))
(cond ((not return))
- (move-return-uses fun call next-block)))
- (t
- (aver (node-tail-p call))
- (setf (lambda-return call-fun) return)
- (setf (return-lambda return) call-fun)
+ (move-return-uses fun call next-block)))
+ (t
+ (aver (node-tail-p call))
+ (setf (lambda-return call-fun) return)
+ (setf (return-lambda return) call-fun)
(when (leaf-has-source-name-p clambda)
;; ANSI requires that explicit NOTINLINE be respected.
(or (eq (lambda-inlinep clambda) :notinline)
(when (leaf-has-source-name-p clambda)
;; ANSI requires that explicit NOTINLINE be respected.
(or (eq (lambda-inlinep clambda) :notinline)
- ;; 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))))))
+ ;; If (= LET-CONVERSION 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-conversion 0))
+ (not (eq (lambda-inlinep clambda) :inline))))))
;;; may have references added due to later local inline expansion.
(defun ok-initial-convert-p (fun)
(not (and (leaf-has-source-name-p fun)
;;; may have references added due to later local inline expansion.
(defun ok-initial-convert-p (fun)
(not (and (leaf-has-source-name-p fun)
;;; true if we converted.
(defun maybe-let-convert (clambda)
(declare (type clambda clambda))
;;; true if we converted.
(defun maybe-let-convert (clambda)
(declare (type clambda clambda))
;; We only convert to a LET when the function is a normal local
;; function, has no XEP, and is referenced in exactly one local
;; call. Conversion is also inhibited if the only reference is in
;; We only convert to a LET when the function is a normal local
;; function, has no XEP, and is referenced in exactly one local
;; call. Conversion is also inhibited if the only reference is in
- (null (rest refs))
- (memq (functional-kind clambda) '(nil :assignment))
- (not (functional-entry-fun clambda)))
- (binding* ((ref (first refs))
+ (null (rest refs))
+ (memq (functional-kind clambda) '(nil :assignment))
+ (not (functional-entry-fun clambda)))
+ (binding* ((ref (first refs))
- (when (and (basic-combination-p dest)
- (eq (basic-combination-fun dest) ref-lvar)
- (eq (basic-combination-kind dest) :local)
+ (when (and (basic-combination-p dest)
+ (eq (basic-combination-fun dest) ref-lvar)
+ (eq (basic-combination-kind dest) :local)
- (do ((cleanup (block-end-cleanup block1)
- (node-enclosing-cleanup (cleanup-mess-up cleanup))))
- ((eq cleanup cleanup2) t)
- (case (cleanup-kind cleanup)
- ((:block :tagbody)
- (unless (null (entry-exits (cleanup-mess-up cleanup)))
- (return nil)))
- (t (return nil)))))))
+ (do ((cleanup (block-end-cleanup block1)
+ (node-enclosing-cleanup (cleanup-mess-up cleanup))))
+ ((eq cleanup cleanup2) t)
+ (case (cleanup-kind cleanup)
+ ((:block :tagbody)
+ (unless (null (entry-exits (cleanup-mess-up cleanup)))
+ (return nil)))
+ (t (return nil)))))))
- (setf (node-tail-p call) t)
- (unlink-blocks block (first (block-succ block)))
- (link-blocks block (lambda-block fun))
+ (setf (node-tail-p call) t)
+ (unlink-blocks block (first (block-succ block)))
+ (link-blocks block (lambda-block fun))
;;; combined with the calling function's environment. We can convert
;;; when:
;;; -- The function is a normal, non-entry function, and
;;; combined with the calling function's environment. We can convert
;;; when:
;;; -- The function is a normal, non-entry function, and
(defun maybe-convert-to-assignment (clambda)
(declare (type clambda clambda))
(when (and (not (functional-kind clambda))
(defun maybe-convert-to-assignment (clambda)
(declare (type clambda clambda))
(when (and (not (functional-kind clambda))
- (let ((home (node-home-lambda ref)))
- (unless (eq home clambda)
- (when outside-call
- (return nil))
- (setq outside-call dest))
- (unless (node-tail-p dest)
- (when (or outside-non-tail-call (eq home clambda))
- (return nil))
- (setq outside-non-tail-call dest)))))
- (ok-initial-convert-p clambda))
+ (let ((home (node-home-lambda ref)))
+ (unless (eq home clambda)
+ (when outside-call
+ (return nil))
+ (setq outside-call dest))
+ (unless (node-tail-p dest)
+ (when (or outside-non-tail-call (eq home clambda))
+ (return nil))
+ (setq outside-non-tail-call dest)))))
+ (ok-initial-convert-p clambda))
(cond (outside-call (setf (functional-kind clambda) :assignment)
(let-convert clambda outside-call)
(when outside-non-tail-call
(cond (outside-call (setf (functional-kind clambda) :assignment)
(let-convert clambda outside-call)
(when outside-non-tail-call