X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=e89af4d35be0090bdae705928348841a0a1fdb5a;hb=ffa9a31f62e3e2abab8ebcbb3bfdab9725feaf7f;hp=058856565606aeba0dd92b752d06a60904fc5f63;hpb=28dcf682ef2a3c80b7bcdda00787dbb5e3893abe;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 0588565..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 @@ -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,28 +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))) + (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 @@ -471,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)) @@ -543,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) @@ -567,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 @@ -629,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 @@ -643,15 +707,11 @@ (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 @@ -667,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:) @@ -680,17 +740,16 @@ (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 @@ -699,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 @@ -858,9 +914,11 @@ (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