X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=274ce421a8f7312a045d7d7e0eb7c3e838cb3df9;hb=b63c4fb9b98fa8188e17ba926e150ba417a74635;hp=7252c64ec263f9993aaab0a8bcd4318a0fe36f27;hpb=6053e7f804b430144bb09e2d107ad4ab3fb97db4;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 7252c64..274ce42 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -69,6 +69,7 @@ result of Value-Form." (unless (symbolp name) (compiler-error "The block name ~S is not a symbol." name)) + (start-block start) (ctran-starts-block next) (let* ((dummy (make-ctran)) (entry (make-entry)) @@ -108,11 +109,14 @@ (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) @@ -120,7 +124,7 @@ (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 (
* (go )). That is, we break up the @@ -162,6 +166,7 @@ to the next statement following that tag. A Tag must an integer or a symbol. A statement must be a list. Other objects are illegal within the body." + (start-block start) (ctran-starts-block next) (let* ((dummy (make-ctran)) (entry (make-entry)) @@ -253,6 +258,8 @@ (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 @@ -276,6 +283,9 @@ (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)) @@ -324,10 +334,14 @@ (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) @@ -388,7 +402,7 @@ (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)) @@ -426,24 +440,45 @@ (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 (debug-namify "#'" 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))) ;;;; FUNCALL @@ -461,8 +496,8 @@ (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)) @@ -477,8 +512,7 @@ `(%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) @@ -522,7 +556,10 @@ (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) @@ -531,22 +568,26 @@ 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-namify "LET S" + 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) @@ -554,11 +595,18 @@ "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 @@ -600,6 +648,9 @@ (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) @@ -608,6 +659,29 @@ . ,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 @@ -618,17 +692,16 @@ (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)) + "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 @@ -638,46 +711,46 @@ 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-namify + "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-namify + "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))))))) + ;;;; the THE special operator, and friends @@ -828,12 +901,15 @@ ;;; 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-namify "escape function for " 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 @@ -859,9 +935,8 @@ (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) @@ -939,6 +1014,7 @@ Evaluate Values-Form and then the Forms, but return all the values of Values-Form." (let ((dummy (make-ctran))) + (ctran-starts-block dummy) (ir1-convert start dummy result values-form) (ir1-convert-progn-body dummy next nil forms)))