X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=e89af4d35be0090bdae705928348841a0a1fdb5a;hb=ffa9a31f62e3e2abab8ebcbb3bfdab9725feaf7f;hp=fc91bee8dbfdc4b69d3d1dbf88784b2ef64a777e;hpb=ff92598854bf7cae8d57fe49cef4d9a98e1ab345;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index fc91bee..e89af4d 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -109,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) @@ -121,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 @@ -281,8 +284,8 @@ (unless (symbolp name) (fail "The local macro name ~S is not a symbol." name)) (when (fboundp name) - (with-single-package-locked-error - (:symbol name "binding ~A as a local macro"))) + (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)) @@ -332,8 +335,8 @@ (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)) - (with-single-package-locked-error - (:symbol name "binding ~A as a local symbol-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" @@ -399,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)) @@ -432,29 +435,59 @@ (reference-constant start next result thing)) ;;;; 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) - :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))) ;;;; FUNCALL @@ -472,8 +505,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)) @@ -534,8 +567,8 @@ (vals (second spec))))))) (dolist (name (names)) (when (eq (info :variable :kind name) :macro) - (with-single-package-locked-error - (:symbol name "lexically binding symbol-macro ~A")))) + (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) @@ -544,23 +577,27 @@ 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) @@ -568,16 +605,19 @@ "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 @@ -620,8 +660,8 @@ (let ((name (first def))) (check-fun-name name) (when (fboundp name) - (with-single-package-locked-error - (:symbol name "binding ~A as a local function"))) + (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) @@ -630,6 +670,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 @@ -644,16 +707,11 @@ (let ((fvars (mapcar (lambda (n d) (ir1-convert-lambda d :source-name n - :debug-name (debug-namify - "FLET " 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 @@ -669,8 +727,8 @@ (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:) @@ -682,18 +740,16 @@ (mapcar (lambda (name def) (ir1-convert-lambda def :source-name name - :debug-name (debug-namify - "LABELS " name) - :allow-debug-catch-tag t)) + :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 @@ -702,10 +758,7 @@ ;; 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 @@ -857,12 +910,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 " 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