(ctran-starts-block next)
(let* ((found (or (lexenv-find name blocks)
(compiler-error "return for unknown block: ~S" name)))
+ (exit-ctran (second found))
(value-ctran (make-ctran))
(value-lvar (make-lvar))
(entry (first found))
(exit (make-exit :entry entry
:value value-lvar)))
+ (when (ctran-deleted-p exit-ctran)
+ (throw 'locall-already-let-converted exit-ctran))
(push exit (entry-exits entry))
(setf (lvar-dest value-lvar) exit)
(ir1-convert start value-ctran value-lvar value)
(let ((home-lambda (ctran-home-lambda-or-null start)))
(when home-lambda
(push entry (lambda-calls-or-closes home-lambda))))
- (use-continuation exit (second found) (third found))))
+ (use-continuation exit exit-ctran (third found))))
;;; Return a list of the segments of a TAGBODY. Each segment looks
;;; like (<tag> <form>* (go <next tag>)). That is, we break up the
(reference-constant start next result thing))
\f
;;;; FUNCTION and NAMED-LAMBDA
+(defun name-lambdalike (thing)
+ (ecase (car thing)
+ ((named-lambda)
+ (second thing))
+ ((lambda instance-lambda)
+ `(lambda ,(second thing)))
+ ((lambda-with-lexenv)'
+ `(lambda ,(fifth thing)))))
+
(defun fun-name-leaf (thing)
(if (consp thing)
(cond
((member (car thing)
'(lambda named-lambda instance-lambda lambda-with-lexenv))
- (ir1-convert-lambdalike
- thing
- :debug-name (debug-namify "#'" thing)))
+ (values (ir1-convert-lambdalike
+ thing
+ :debug-name (name-lambdalike thing))
+ t))
((legal-fun-name-p thing)
- (find-lexically-apparent-fun
- thing "as the argument to FUNCTION"))
+ (values (find-lexically-apparent-fun
+ thing "as the argument to FUNCTION")
+ nil))
(t
(compiler-error "~S is not a legal function name." thing)))
- (find-lexically-apparent-fun
- thing "as the argument to FUNCTION")))
+ (values (find-lexically-apparent-fun
+ thing "as the argument to FUNCTION")
+ nil)))
+
+(def-ir1-translator %%allocate-closures ((&rest leaves) start next result)
+ (aver (eq result 'nil))
+ (let ((lambdas leaves))
+ (ir1-convert start next result `(%allocate-closures ',lambdas))
+ (let ((allocator (node-dest (ctran-next start))))
+ (dolist (lambda lambdas)
+ (setf (functional-allocator lambda) allocator)))))
+
+(defmacro with-fun-name-leaf ((leaf thing start) &body body)
+ `(multiple-value-bind (,leaf allocate-p) (fun-name-leaf ,thing)
+ (if allocate-p
+ (let ((.new-start. (make-ctran)))
+ (ir1-convert ,start .new-start. nil `(%%allocate-closures ,leaf))
+ (let ((,start .new-start.))
+ ,@body))
+ (locally
+ ,@body))))
(def-ir1-translator function ((thing) start next result)
#!+sb-doc
"FUNCTION Name
Return the lexically apparent definition of the function Name. Name may also
be a lambda expression."
- (reference-leaf start next result (fun-name-leaf thing)))
+ (with-fun-name-leaf (leaf thing start)
+ (reference-leaf start next result leaf)))
\f
;;;; FUNCALL
(def-ir1-translator %funcall ((function &rest args) start next result)
(if (and (consp function) (eq (car function) 'function))
- (ir1-convert start next result
- `(,(fun-name-leaf (second function)) ,@args))
+ (with-fun-name-leaf (leaf (second function) start)
+ (ir1-convert start next result `(,leaf ,@args)))
(let ((ctran (make-ctran))
(fun-lvar (make-lvar)))
(ir1-convert start ctran fun-lvar `(the function ,function))
During evaluation of the Forms, bind the Vars to the result of evaluating the
Value forms. The variables are bound in parallel after all of the Values are
evaluated."
- (if (null bindings)
- (ir1-translate-locally body start next result)
- (multiple-value-bind (forms decls)
- (parse-body body :doc-string-allowed nil)
- (multiple-value-bind (vars values) (extract-let-vars bindings 'let)
- (binding* ((ctran (make-ctran))
- (fun-lvar (make-lvar))
- ((next result)
- (processing-decls (decls vars nil next result)
- (let ((fun (ir1-convert-lambda-body
- forms
- vars
- :debug-name (debug-namify "LET S"
- bindings))))
- (reference-leaf start ctran fun-lvar fun))
- (values next result))))
- (ir1-convert-combination-args fun-lvar ctran next result values))))))
+ (cond ((null bindings)
+ (ir1-translate-locally body start next result))
+ ((listp bindings)
+ (multiple-value-bind (forms decls)
+ (parse-body body :doc-string-allowed nil)
+ (multiple-value-bind (vars values) (extract-let-vars bindings 'let)
+ (binding* ((ctran (make-ctran))
+ (fun-lvar (make-lvar))
+ ((next result)
+ (processing-decls (decls vars nil next result)
+ (let ((fun (ir1-convert-lambda-body
+ forms
+ vars
+ :debug-name (debug-name 'let bindings))))
+ (reference-leaf start ctran fun-lvar fun))
+ (values next result))))
+ (ir1-convert-combination-args fun-lvar ctran next result values)))))
+ (t
+ (compiler-error "Malformed LET bindings: ~S." bindings))))
(def-ir1-translator let* ((bindings &body body)
start next result)
"LET* ({(Var [Value]) | Var}*) Declaration* Form*
Similar to LET, but the variables are bound sequentially, allowing each Value
form to reference any of the previous Vars."
- (multiple-value-bind (forms decls)
- (parse-body body :doc-string-allowed nil)
- (multiple-value-bind (vars values) (extract-let-vars bindings 'let*)
- (processing-decls (decls vars nil start next)
- (ir1-convert-aux-bindings start
- next
- result
- forms
- vars
- values)))))
+ (if (listp bindings)
+ (multiple-value-bind (forms decls)
+ (parse-body body :doc-string-allowed nil)
+ (multiple-value-bind (vars values) (extract-let-vars bindings 'let*)
+ (processing-decls (decls vars nil start next)
+ (ir1-convert-aux-bindings start
+ next
+ result
+ forms
+ vars
+ values))))
+ (compiler-error "Malformed LET* bindings: ~S." bindings)))
;;; logic shared between IR1 translators for LOCALLY, MACROLET,
;;; and SYMBOL-MACROLET
. ,forms))))))
(values (names) (defs))))
+(defun ir1-convert-fbindings (start next result funs body)
+ (let ((ctran (make-ctran))
+ (dx-p (find-if #'leaf-dynamic-extent funs)))
+ (when dx-p
+ (ctran-starts-block ctran)
+ (ctran-starts-block next))
+ (ir1-convert start ctran nil `(%%allocate-closures ,@funs))
+ (cond (dx-p
+ (let* ((dummy (make-ctran))
+ (entry (make-entry))
+ (cleanup (make-cleanup :kind :dynamic-extent
+ :mess-up entry
+ :info (list (node-dest
+ (ctran-next start))))))
+ (push entry (lambda-entries (lexenv-lambda *lexenv*)))
+ (setf (entry-cleanup entry) cleanup)
+ (link-node-to-previous-ctran entry ctran)
+ (use-ctran entry dummy)
+
+ (let ((*lexenv* (make-lexenv :cleanup cleanup)))
+ (ir1-convert-progn-body dummy next result body))))
+ (t (ir1-convert-progn-body ctran next result body)))))
+
(def-ir1-translator flet ((definitions &body body)
start next result)
#!+sb-doc
(let ((fvars (mapcar (lambda (n d)
(ir1-convert-lambda d
:source-name n
- :debug-name (debug-namify
- "FLET " n)))
+ :debug-name (debug-name 'flet n)))
names defs)))
(processing-decls (decls nil fvars next result)
(let ((*lexenv* (make-lexenv :funs (pairlis names fvars))))
- (ir1-convert-progn-body start
- next
- result
- forms)))))))
+ (ir1-convert-fbindings start next result fvars forms)))))))
(def-ir1-translator labels ((definitions &body body) start next result)
#!+sb-doc
(placeholder-funs (mapcar (lambda (name)
(make-functional
:%source-name name
- :%debug-name (debug-namify
- "LABELS placeholder "
+ :%debug-name (debug-name
+ 'labels-placeholder
name)))
names))
;; (like PAIRLIS but guaranteed to preserve ordering:)
(mapcar (lambda (name def)
(ir1-convert-lambda def
:source-name name
- :debug-name (debug-namify
- "LABELS " name)))
+ :debug-name (debug-name 'labels name)))
names defs))))
-
+
;; Modify all the references to the dummy function leaves so
;; that they point to the real function leaves.
(loop for real-fun in real-funs and
placeholder-cons in placeholder-fenv do
(substitute-leaf real-fun (cdr placeholder-cons))
(setf (cdr placeholder-cons) real-fun))
-
+
;; Voila.
(processing-decls (decls nil real-funs next result)
(let ((*lexenv* (make-lexenv
;; lexical environment is used for inline
;; expansion we'll get the right functions.
:funs (pairlis names real-funs))))
- (ir1-convert-progn-body start
- next
- result
- forms)))))))
+ (ir1-convert-fbindings start next result real-funs forms)))))))
\f
;;;; the THE special operator, and friends
(ir1-convert-lambda
`(lambda ()
(return-from ,tag (%unknown-values)))
- :debug-name (debug-namify "escape function for " tag)))))
+ :debug-name (debug-name 'escape-fun tag))))
+ (ctran (make-ctran)))
(setf (functional-kind fun) :escape)
- (reference-leaf start next result fun)))
+ (ir1-convert start ctran nil `(%%allocate-closures ,fun))
+ (reference-leaf ctran next result fun)))
;;; Yet another special special form. This one looks up a local
;;; function and smashes it to a :CLEANUP function, as well as
projects / sbcl.git / blobdiff