(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
(compiler-style-warn "duplicate definitions in ~S" definitions))
(let* ((processed-definitions (mapcar definitionize-fun definitions))
(*lexenv* (make-lexenv definitionize-keyword processed-definitions)))
+ ;; I wonder how much of an compiler performance penalty this
+ ;; non-constant keyword is.
(funcall fun definitionize-keyword processed-definitions)))
;;; Tweak LEXENV to include the DEFINITIONS from a MACROLET, then
(destructuring-bind (name arglist &body body) definition
(unless (symbolp name)
(fail "The local macro name ~S is not a symbol." name))
+ (when (fboundp name)
+ (compiler-assert-symbol-home-package-unlocked
+ name "binding ~A as a local macro"))
(unless (listp arglist)
(fail "The local macro argument list ~S is not a list."
arglist))
(destructuring-bind (name expansion) definition
(unless (symbolp name)
(fail "The local symbol macro name ~S is not a symbol." name))
+ (when (or (boundp name) (eq (info :variable :kind name) :macro))
+ (compiler-assert-symbol-home-package-unlocked
+ name "binding ~A as a local symbol-macro"))
(let ((kind (info :variable :kind name)))
(when (member kind '(:special :constant))
(fail "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S"
kind name)))
+ ;; A magical cons that MACROEXPAND-1 understands.
`(,name . (MACRO . ,expansion))))))
(defun funcall-in-symbol-macrolet-lexenv (definitions fun context)
(if (template-more-args-type template)
(when (< nargs min)
(bug "Primitive ~A was called with ~R argument~:P, ~
- but wants at least ~R."
+ but wants at least ~R."
name
nargs
min))
(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 "#'~S" thing)
- :allow-debug-catch-tag t))
+ (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))
`(%funcall ,function ,@args)
(values nil t)))
-(deftransform %coerce-callable-to-fun ((thing) (function) *
- :important t)
+(deftransform %coerce-callable-to-fun ((thing) (function) *)
"optimize away possible call to FDEFINITION at runtime"
'thing)
\f
(vars var)
(names name)
(vals (second spec)))))))
-
+ (dolist (name (names))
+ (when (eq (info :variable :kind name) :macro)
+ (compiler-assert-symbol-home-package-unlocked
+ name "lexically binding symbol-macro ~A")))
(values (vars) (vals))))
(def-ir1-translator let ((bindings &body body) start next result)
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
+ post-binding-lexenv)
+ (let ((fun (ir1-convert-lambda-body
+ forms
+ vars
+ :post-binding-lexenv post-binding-lexenv
+ :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 post-binding-lexenv)
+ (ir1-convert-aux-bindings start
+ next
+ result
+ forms
+ vars
+ values
+ post-binding-lexenv))))
+ (compiler-error "Malformed LET* bindings: ~S." bindings)))
;;; logic shared between IR1 translators for LOCALLY, MACROLET,
;;; and SYMBOL-MACROLET
(let ((name (first def)))
(check-fun-name name)
+ (when (fboundp name)
+ (compiler-assert-symbol-home-package-unlocked
+ name "binding ~A as a local function"))
(names name)
(multiple-value-bind (forms decls) (parse-body (cddr def))
(defs `(lambda ,(second def)
. ,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
(multiple-value-bind (forms decls)
(parse-body body :doc-string-allowed nil)
(multiple-value-bind (names defs)
- (extract-flet-vars definitions 'flet)
+ (extract-flet-vars definitions 'flet)
(let ((fvars (mapcar (lambda (n d)
(ir1-convert-lambda d
:source-name n
- :debug-name (debug-namify
- "FLET ~S" n)
- :allow-debug-catch-tag t))
+ :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
each other."
(multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
(multiple-value-bind (names defs)
- (extract-flet-vars definitions 'labels)
- (let* ( ;; dummy LABELS functions, to be used as placeholders
+ (extract-flet-vars definitions 'labels)
+ (let* (;; dummy LABELS functions, to be used as placeholders
;; during construction of real LABELS functions
- (placeholder-funs (mapcar (lambda (name)
- (make-functional
- :%source-name name
- :%debug-name (debug-namify
- "LABELS placeholder ~S"
- name)))
- names))
- ;; (like PAIRLIS but guaranteed to preserve ordering:)
- (placeholder-fenv (mapcar #'cons names placeholder-funs))
+ (placeholder-funs (mapcar (lambda (name)
+ (make-functional
+ :%source-name name
+ :%debug-name (debug-name
+ 'labels-placeholder
+ name)))
+ names))
+ ;; (like PAIRLIS but guaranteed to preserve ordering:)
+ (placeholder-fenv (mapcar #'cons names placeholder-funs))
;; the real LABELS functions, compiled in a LEXENV which
;; includes the dummy LABELS functions
- (real-funs
- (let ((*lexenv* (make-lexenv :funs placeholder-fenv)))
- (mapcar (lambda (name def)
- (ir1-convert-lambda def
- :source-name name
- :debug-name (debug-namify
- "LABELS ~S" name)
- :allow-debug-catch-tag t))
- names defs))))
+ (real-funs
+ (let ((*lexenv* (make-lexenv :funs placeholder-fenv)))
+ (mapcar (lambda (name def)
+ (ir1-convert-lambda def
+ :source-name 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))
+ (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)
+ (processing-decls (decls nil real-funs next result)
(let ((*lexenv* (make-lexenv
;; Use a proper FENV here (not the
;; placeholder used earlier) so that if the
;; 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
;;; Note that environment analysis replaces references to escape
;;; functions with references to the corresponding NLX-INFO structure.
(def-ir1-translator %escape-fun ((tag) start next result)
- (let ((fun (ir1-convert-lambda
- `(lambda ()
- (return-from ,tag (%unknown-values)))
- :debug-name (debug-namify "escape function for ~S" tag))))
+ (let ((fun (let ((*allow-instrumenting* nil))
+ (ir1-convert-lambda
+ `(lambda ()
+ (return-from ,tag (%unknown-values)))
+ :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
(with-unique-names (exit-block)
`(block ,exit-block
(%within-cleanup
- :catch
- (%catch (%escape-fun ,exit-block) ,tag)
- ,@body)))))
+ :catch (%catch (%escape-fun ,exit-block) ,tag)
+ ,@body)))))
(def-ir1-translator unwind-protect
((protected &body cleanup) start next result)
projects / sbcl.git / blobdiff