X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=95d57484ec2c7de7fe52ea1a1794e2b8be638626;hb=bea5b384106a6734a4b280a76e8ebdd4d51b5323;hp=892ddfce809a09ba0aad767e85f90ba5fc696ca1;hpb=bd0ba0f214518e8d72ff2d44de5a1e3e4b02af2c;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 892ddfc..95d5748 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -14,43 +14,42 @@ ;;;; special forms for control -(def-ir1-translator progn ((&rest forms) start cont) +(def-ir1-translator progn ((&rest forms) start next result) #!+sb-doc "Progn Form* Evaluates each Form in order, returning the values of the last form. With no forms, returns NIL." - (ir1-convert-progn-body start cont forms)) + (ir1-convert-progn-body start next result forms)) -(def-ir1-translator if ((test then &optional else) start cont) +(def-ir1-translator if ((test then &optional else) start next result) #!+sb-doc "If Predicate Then [Else] If Predicate evaluates to non-null, evaluate Then and returns its values, otherwise evaluate Else and return its values. Else defaults to NIL." - (let* ((pred (make-continuation)) - (then-cont (make-continuation)) - (then-block (continuation-starts-block then-cont)) - (else-cont (make-continuation)) - (else-block (continuation-starts-block else-cont)) - (dummy-cont (make-continuation)) - (node (make-if :test pred + (let* ((pred-ctran (make-ctran)) + (pred-lvar (make-lvar)) + (then-ctran (make-ctran)) + (then-block (ctran-starts-block then-ctran)) + (else-ctran (make-ctran)) + (else-block (ctran-starts-block else-ctran)) + (node (make-if :test pred-lvar :consequent then-block :alternative else-block))) ;; IR1-CONVERT-MAYBE-PREDICATE requires DEST to be CIF, so the ;; order of the following two forms is important - (setf (continuation-dest pred) node) - (ir1-convert start pred test) - (link-node-to-previous-continuation node pred) - (use-continuation node dummy-cont) + (setf (lvar-dest pred-lvar) node) + (ir1-convert start pred-ctran pred-lvar test) + (link-node-to-previous-ctran node pred-ctran) - (let ((start-block (continuation-block pred))) + (let ((start-block (ctran-block pred-ctran))) (setf (block-last start-block) node) - (continuation-starts-block cont) + (ctran-starts-block next) (link-blocks start-block then-block) (link-blocks start-block else-block)) - (ir1-convert then-cont cont then) - (ir1-convert else-cont cont else))) + (ir1-convert then-ctran next result then) + (ir1-convert else-ctran next result else))) ;;;; BLOCK and TAGBODY @@ -59,10 +58,10 @@ ;;;; node. ;;; Make a :ENTRY cleanup and emit an ENTRY node, then convert the -;;; body in the modified environment. We make CONT start a block now, +;;; body in the modified environment. We make NEXT start a block now, ;;; since if it was done later, the block would be in the wrong ;;; environment. -(def-ir1-translator block ((name &rest forms) start cont) +(def-ir1-translator block ((name &rest forms) start next result) #!+sb-doc "Block Name Form* Evaluate the Forms as a PROGN. Within the lexical scope of the body, @@ -70,32 +69,32 @@ result of Value-Form." (unless (symbolp name) (compiler-error "The block name ~S is not a symbol." name)) - (continuation-starts-block cont) - (let* ((dummy (make-continuation)) + (start-block start) + (ctran-starts-block next) + (let* ((dummy (make-ctran)) (entry (make-entry)) (cleanup (make-cleanup :kind :block :mess-up entry))) (push entry (lambda-entries (lexenv-lambda *lexenv*))) (setf (entry-cleanup entry) cleanup) - (link-node-to-previous-continuation entry start) - (use-continuation entry dummy) + (link-node-to-previous-ctran entry start) + (use-ctran entry dummy) - (let* ((env-entry (list entry cont)) + (let* ((env-entry (list entry next result)) (*lexenv* (make-lexenv :blocks (list (cons name env-entry)) :cleanup cleanup))) - (push env-entry (continuation-lexenv-uses cont)) - (ir1-convert-progn-body dummy cont forms)))) + (ir1-convert-progn-body dummy next result forms)))) -(def-ir1-translator return-from ((name &optional value) start cont) +(def-ir1-translator return-from ((name &optional value) start next result) #!+sb-doc "Return-From Block-Name Value-Form Evaluate the Value-Form, returning its values from the lexically enclosing BLOCK Block-Name. This is constrained to be used only within the dynamic extent of the BLOCK." - ;; CMU CL comment: - ;; We make CONT start a block just so that it will have a block - ;; assigned. People assume that when they pass a continuation into - ;; IR1-CONVERT as CONT, it will have a block when it is done. + ;; old comment: + ;; We make NEXT start a block just so that it will have a block + ;; assigned. People assume that when they pass a ctran into + ;; IR1-CONVERT as NEXT, it will have a block when it is done. ;; KLUDGE: Note that this block is basically fictitious. In the code ;; (BLOCK B (RETURN-FROM B) (SETQ X 3)) ;; it's the block which answers the question "which block is @@ -106,21 +105,26 @@ ;; BLOCK-HOME-LAMBDA-OR-NULL) more obscure, and it might be better ;; to get rid of it, perhaps using a special placeholder value ;; to indicate the orphanedness of the code. - (continuation-starts-block cont) + (declare (ignore result)) + (ctran-starts-block next) (let* ((found (or (lexenv-find name blocks) (compiler-error "return for unknown block: ~S" name))) - (value-cont (make-continuation)) + (exit-ctran (second found)) + (value-ctran (make-ctran)) + (value-lvar (make-lvar)) (entry (first found)) (exit (make-exit :entry entry - :value value-cont))) + :value value-lvar))) + (when (ctran-deleted-p exit-ctran) + (throw 'locall-already-let-converted exit-ctran)) (push exit (entry-exits entry)) - (setf (continuation-dest value-cont) exit) - (ir1-convert start value-cont value) - (link-node-to-previous-continuation exit value-cont) - (let ((home-lambda (continuation-home-lambda-or-null start))) + (setf (lvar-dest value-lvar) exit) + (ir1-convert start value-ctran value-lvar value) + (link-node-to-previous-ctran exit value-ctran) + (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)))) + (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 @@ -153,7 +157,7 @@ ;;; each tag, building up the tag list for LEXENV-TAGS as we go. ;;; Finally, convert each segment with the precomputed Start and Cont ;;; values. -(def-ir1-translator tagbody ((&rest statements) start cont) +(def-ir1-translator tagbody ((&rest statements) start next result) #!+sb-doc "Tagbody {Tag | Statement}* Define tags for used with GO. The Statements are evaluated in order @@ -162,54 +166,56 @@ 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." - (continuation-starts-block cont) - (let* ((dummy (make-continuation)) + (start-block start) + (ctran-starts-block next) + (let* ((dummy (make-ctran)) (entry (make-entry)) (segments (parse-tagbody statements)) (cleanup (make-cleanup :kind :tagbody :mess-up entry))) (push entry (lambda-entries (lexenv-lambda *lexenv*))) (setf (entry-cleanup entry) cleanup) - (link-node-to-previous-continuation entry start) - (use-continuation entry dummy) + (link-node-to-previous-ctran entry start) + (use-ctran entry dummy) (collect ((tags) (starts) - (conts)) + (ctrans)) (starts dummy) (dolist (segment (rest segments)) - (let* ((tag-cont (make-continuation)) - (tag (list (car segment) entry tag-cont))) - (conts tag-cont) - (starts tag-cont) - (continuation-starts-block tag-cont) - (tags tag) - (push (cdr tag) (continuation-lexenv-uses tag-cont)))) - (conts cont) + (let* ((tag-ctran (make-ctran)) + (tag (list (car segment) entry tag-ctran))) + (ctrans tag-ctran) + (starts tag-ctran) + (ctran-starts-block tag-ctran) + (tags tag))) + (ctrans next) (let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags)))) - (mapc (lambda (segment start cont) - (ir1-convert-progn-body start cont (rest segment))) - segments (starts) (conts)))))) + (mapc (lambda (segment start end) + (ir1-convert-progn-body start end + (when (eq end next) result) + (rest segment))) + segments (starts) (ctrans)))))) ;;; Emit an EXIT node without any value. -(def-ir1-translator go ((tag) start cont) +(def-ir1-translator go ((tag) start next result) #!+sb-doc "Go Tag Transfer control to the named Tag in the lexically enclosing TAGBODY. This is constrained to be used only within the dynamic extent of the TAGBODY." - (continuation-starts-block cont) + (ctran-starts-block next) (let* ((found (or (lexenv-find tag tags :test #'eql) (compiler-error "attempt to GO to nonexistent tag: ~S" tag))) (entry (first found)) (exit (make-exit :entry entry))) (push exit (entry-exits entry)) - (link-node-to-previous-continuation exit start) - (let ((home-lambda (continuation-home-lambda-or-null start))) + (link-node-to-previous-ctran exit start) + (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)))) + (use-ctran exit (second found)))) ;;;; translators for compiler-magic special forms @@ -225,14 +231,14 @@ ;;; eval-when specifying the :EXECUTE situation is treated as an ;;; implicit PROGN including the forms in the body of the EVAL-WHEN ;;; form; otherwise, the forms in the body are ignored. -(def-ir1-translator eval-when ((situations &rest forms) start cont) +(def-ir1-translator eval-when ((situations &rest forms) start next result) #!+sb-doc "EVAL-WHEN (Situation*) Form* Evaluate the Forms in the specified Situations (any of :COMPILE-TOPLEVEL, :LOAD-TOPLEVEL, or :EXECUTE, or (deprecated) COMPILE, LOAD, or EVAL)." (multiple-value-bind (ct lt e) (parse-eval-when-situations situations) (declare (ignore ct lt)) - (ir1-convert-progn-body start cont (and e forms))) + (ir1-convert-progn-body start next result (and e forms))) (values)) ;;; common logic for MACROLET and SYMBOL-MACROLET @@ -252,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 @@ -261,45 +269,46 @@ ;;; shared by the special-case top level MACROLET processing code, and ;;; further split so that the special-case MACROLET processing code in ;;; EVAL can likewise make use of it. -(defmacro macrolet-definitionize-fun (context lexenv) - (flet ((make-error-form (control &rest args) +(defun macrolet-definitionize-fun (context lexenv) + (flet ((fail (control &rest args) (ecase context - (:compile `(compiler-error ,control ,@args)) - (:eval `(error 'simple-program-error - :format-control ,control - :format-arguments (list ,@args)))))) - `(lambda (definition) + (:compile (apply #'compiler-error control args)) + (:eval (error 'simple-program-error + :format-control control + :format-arguments args))))) + (lambda (definition) (unless (list-of-length-at-least-p definition 2) - ,(make-error-form - "The list ~S is too short to be a legal local macro definition." - 'definition)) + (fail "The list ~S is too short to be a legal local macro definition." + definition)) (destructuring-bind (name arglist &body body) definition - (unless (symbolp name) - ,(make-error-form "The local macro name ~S is not a symbol." 'name)) - (unless (listp arglist) - ,(make-error-form - "The local macro argument list ~S is not a list." - 'arglist)) - (with-unique-names (whole environment) - (multiple-value-bind (body local-decls) - (parse-defmacro arglist whole body name 'macrolet - :environment environment) - `(,name macro . - ,(compile-in-lexenv - nil - `(lambda (,whole ,environment) - ,@local-decls - (block ,name ,body)) - ,lexenv)))))))) - -(defun funcall-in-macrolet-lexenv (definitions fun) + (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)) + (with-unique-names (whole environment) + (multiple-value-bind (body local-decls) + (parse-defmacro arglist whole body name 'macrolet + :environment environment) + `(,name macro . + ,(compile-in-lexenv + nil + `(lambda (,whole ,environment) + ,@local-decls + ,body) + lexenv)))))))) + +(defun funcall-in-macrolet-lexenv (definitions fun context) (%funcall-in-foomacrolet-lexenv - (macrolet-definitionize-fun :compile (make-restricted-lexenv *lexenv*)) + (macrolet-definitionize-fun context (make-restricted-lexenv *lexenv*)) :funs definitions fun)) -(def-ir1-translator macrolet ((definitions &rest body) start cont) +(def-ir1-translator macrolet ((definitions &rest body) start next result) #!+sb-doc "MACROLET ({(Name Lambda-List Form*)}*) Body-Form* Evaluate the Body-Forms in an environment with the specified local macros @@ -309,38 +318,41 @@ definitions (lambda (&key funs) (declare (ignore funs)) - (ir1-translate-locally body start cont)))) + (ir1-translate-locally body start next result)) + :compile)) -(defmacro symbol-macrolet-definitionize-fun (context) - (flet ((make-error-form (control &rest args) +(defun symbol-macrolet-definitionize-fun (context) + (flet ((fail (control &rest args) (ecase context - (:compile `(compiler-error ,control ,@args)) - (:eval `(error 'simple-program-error - :format-control ,control - :format-arguments (list ,@args)))))) - `(lambda (definition) + (:compile (apply #'compiler-error control args)) + (:eval (error 'simple-program-error + :format-control control + :format-arguments args))))) + (lambda (definition) (unless (proper-list-of-length-p definition 2) - ,(make-error-form "malformed symbol/expansion pair: ~S" 'definition)) - (destructuring-bind (name expansion) definition - (unless (symbolp name) - ,(make-error-form - "The local symbol macro name ~S is not a symbol." - 'name)) - (let ((kind (info :variable :kind name))) - (when (member kind '(:special :constant)) - ,(make-error-form - "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S" - 'kind 'name))) - `(,name . (MACRO . ,expansion))))))1 - -(defun funcall-in-symbol-macrolet-lexenv (definitions fun) + (fail "malformed symbol/expansion pair: ~S" definition)) + (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) (%funcall-in-foomacrolet-lexenv - (symbol-macrolet-definitionize-fun :compile) + (symbol-macrolet-definitionize-fun context) :vars definitions fun)) -(def-ir1-translator symbol-macrolet ((macrobindings &body body) start cont) +(def-ir1-translator symbol-macrolet + ((macrobindings &body body) start next result) #!+sb-doc "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form* Define the Names as symbol macros with the given Expansions. Within the @@ -348,7 +360,8 @@ (funcall-in-symbol-macrolet-lexenv macrobindings (lambda (&key vars) - (ir1-translate-locally body start cont :vars vars)))) + (ir1-translate-locally body start next result :vars vars)) + :compile)) ;;;; %PRIMITIVE ;;;; @@ -378,7 +391,7 @@ ;;; BACKEND-TEMPLATE-NAMES to BACKEND-VOPS, and rename %PRIMITIVE to ;;; VOP or %VOP.. -- WHN 2001-06-11 ;;; FIXME: Look at doing this ^, it doesn't look too hard actually. -(def-ir1-translator %primitive ((name &rest args) start cont) +(def-ir1-translator %primitive ((name &rest args) start next result) (declare (type symbol name)) (let* ((template (or (gethash name *backend-template-names*) (bug "undefined primitive ~A" name))) @@ -389,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)) @@ -406,8 +419,7 @@ (when (template-more-results-type template) (bug "%PRIMITIVE was used with an unknown values template.")) - (ir1-convert start - cont + (ir1-convert start next result `(%%primitive ',template ',(eval-info-args (subseq args required min)) @@ -416,38 +428,66 @@ ;;;; QUOTE -(def-ir1-translator quote ((thing) start cont) +(def-ir1-translator quote ((thing) start next result) #!+sb-doc "QUOTE Value Return Value without evaluating it." - (reference-constant start cont thing)) + (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))))) -(def-ir1-translator function ((thing) start cont) - #!+sb-doc - "FUNCTION Name - Return the lexically apparent definition of the function Name. Name may also - be a lambda expression." +(defun fun-name-leaf (thing) (if (consp thing) (cond ((member (car thing) '(lambda named-lambda instance-lambda lambda-with-lexenv)) - (reference-leaf start - cont - (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) - (let ((var (find-lexically-apparent-fun - thing "as the argument to FUNCTION"))) - (reference-leaf start cont var))) + (values (find-lexically-apparent-fun + thing "as the argument to FUNCTION") + nil)) (t (compiler-error "~S is not a legal function name." thing))) - (let ((var (find-lexically-apparent-fun - thing "as the argument to FUNCTION"))) - (reference-leaf start cont var)))) + (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." + (with-fun-name-leaf (leaf thing start) + (reference-leaf start next result leaf))) ;;;; FUNCALL @@ -457,18 +497,20 @@ (deftransform funcall ((function &rest args) * *) (let ((arg-names (make-gensym-list (length args)))) `(lambda (function ,@arg-names) - (%funcall ,(if (csubtypep (continuation-type function) + (%funcall ,(if (csubtypep (lvar-type function) (specifier-type 'function)) 'function '(%coerce-callable-to-fun function)) ,@arg-names)))) -(def-ir1-translator %funcall ((function &rest args) start cont) - (let ((fun-cont (make-continuation))) - (ir1-convert start fun-cont function) - (assert-continuation-type fun-cont (specifier-type 'function) - (lexenv-policy *lexenv*)) - (ir1-convert-combination-args fun-cont cont args))) +(def-ir1-translator %funcall ((function &rest args) start next result) + (if (and (consp function) (eq (car function) 'function)) + (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)) + (ir1-convert-combination-args fun-lvar ctran next result args)))) ;;; This source transform exists to reduce the amount of work for the ;;; compiler. If the called function is a FUNCTION form, then convert @@ -479,8 +521,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) @@ -524,38 +565,56 @@ (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 cont) +(def-ir1-translator let ((bindings &body body) start next result) #!+sb-doc "LET ({(Var [Value]) | Var}*) Declaration* Form* 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 cont) - (multiple-value-bind (forms decls) (parse-body body nil) - (multiple-value-bind (vars values) (extract-let-vars bindings 'let) - (let ((fun-cont (make-continuation))) - (let* ((*lexenv* (process-decls decls vars nil cont)) - (fun (ir1-convert-lambda-body - forms vars - :debug-name (debug-namify "LET ~S" bindings)))) - (reference-leaf start fun-cont fun)) - (ir1-convert-combination-args fun-cont cont 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 cont) + start next result) #!+sb-doc "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 nil) - (multiple-value-bind (vars values) (extract-let-vars bindings 'let*) - (let ((*lexenv* (process-decls decls vars nil cont))) - (ir1-convert-aux-bindings start cont 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 @@ -564,19 +623,20 @@ ;;; but we don't need to worry about that within an IR1 translator, ;;; since toplevel-formness is picked off by PROCESS-TOPLEVEL-FOO ;;; forms before we hit the IR1 transform level. -(defun ir1-translate-locally (body start cont &key vars funs) - (declare (type list body) (type continuation start cont)) - (multiple-value-bind (forms decls) (parse-body body nil) - (let ((*lexenv* (process-decls decls vars funs cont))) - (ir1-convert-aux-bindings start cont forms nil nil)))) +(defun ir1-translate-locally (body start next result &key vars funs) + (declare (type ctran start next) (type (or lvar null) result) + (type list body)) + (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) + (processing-decls (decls vars funs next result) + (ir1-convert-progn-body start next result forms)))) -(def-ir1-translator locally ((&body body) start cont) +(def-ir1-translator locally ((&body body) start next result) #!+sb-doc "LOCALLY Declaration* Form* Sequentially evaluate the Forms in a lexical environment where the the Declarations have effect. If LOCALLY is a top level form, then the Forms are also processed as top level forms." - (ir1-translate-locally body start cont)) + (ir1-translate-locally body start next result)) ;;;; FLET and LABELS @@ -596,6 +656,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) @@ -604,177 +667,149 @@ . ,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 cont) + start next result) #!+sb-doc "FLET ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form* Evaluate the Body-Forms with some local function definitions. The bindings do not enclose the definitions; any use of Name in the Forms will refer to the lexically apparent function definition in the enclosing environment." - (multiple-value-bind (forms decls) (parse-body body nil) + (multiple-value-bind (forms decls) + (parse-body body :doc-string-allowed nil) (multiple-value-bind (names defs) - (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)) - names defs)) - (*lexenv* (make-lexenv - :default (process-decls decls nil fvars cont) - :funs (pairlis names fvars)))) - (ir1-convert-progn-body start cont forms))))) - -(def-ir1-translator labels ((definitions &body body) start cont) + (extract-flet-vars definitions 'flet) + (let ((fvars (mapcar (lambda (n d) + (ir1-convert-lambda d + :source-name 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-fbindings start next result fvars forms))))))) + +(def-ir1-translator labels ((definitions &body body) start next result) #!+sb-doc "LABELS ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form* Evaluate the Body-Forms with some local function definitions. The bindings enclose the new definitions, so the defined functions can call themselves or each other." - (multiple-value-bind (forms decls) (parse-body body nil) + (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) (multiple-value-bind (names defs) - (extract-flet-vars definitions 'labels) + (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. - (let ((*lexenv* (make-lexenv - :default (process-decls decls nil real-funs cont) - ;; 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 cont forms)))))) + (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-fbindings start next result real-funs forms))))))) + ;;;; the THE special operator, and friends -;;; Do stuff to recognize a THE or VALUES declaration. CONT is the -;;; continuation that the assertion applies to, TYPE is the type -;;; specifier and LEXENV is the current lexical environment. NAME is -;;; the name of the declaration we are doing, for use in error -;;; messages. -;;; -;;; This is somewhat involved, since a type assertion may only be made -;;; on a continuation, not on a node. We can't just set the -;;; continuation asserted type and let it go at that, since there may -;;; be parallel THE's for the same continuation, i.e. -;;; (if ... -;;; (the foo ...) -;;; (the bar ...)) -;;; -;;; In this case, our representation can do no better than the union -;;; of these assertions. And if there is a branch with no assertion, -;;; we have nothing at all. We really need to recognize scoping, since -;;; we need to be able to discern between parallel assertions (which -;;; we union) and nested ones (which we intersect). -;;; -;;; We represent the scoping by throwing our innermost (intersected) -;;; assertion on CONT into the TYPE-RESTRICTIONS. As we go down, we -;;; intersect our assertions together. If CONT has no uses yet, we -;;; have not yet bottomed out on the first COND branch; in this case -;;; we optimistically assume that this type will be the one we end up -;;; with, and set the ASSERTED-TYPE to it. We can never get better -;;; than the type that we have the first time we bottom out. Later -;;; THE's (or the absence thereof) can only weaken this result. -;;; -;;; We make this work by getting USE-CONTINUATION to do the unioning -;;; across COND branches. We can't do it here, since we don't know how -;;; many branches there are going to be. -(defun ir1ize-the-or-values (type cont lexenv place) - (declare (type continuation cont) (type lexenv lexenv)) - (let* ((atype (if (typep type 'ctype) - type - (compiler-values-specifier-type type))) - (old-atype (or (lexenv-find cont type-restrictions) - *wild-type*)) - (old-ctype (or (lexenv-find cont weakend-type-restrictions) - *wild-type*)) - (intersects (values-types-equal-or-intersect old-atype atype)) - (new-atype (values-type-intersection old-atype atype)) - (new-ctype (values-type-intersection - old-ctype - (maybe-weaken-check atype (lexenv-policy lexenv))))) - (when (null (find-uses cont)) - (setf (continuation-asserted-type cont) new-atype) - (setf (continuation-type-to-check cont) new-ctype)) - (when (and (not intersects) - ;; FIXME: Is it really right to look at *LEXENV* here, - ;; instead of looking at the LEXENV argument? Why? - (not (policy *lexenv* - (= inhibit-warnings 3)))) ;FIXME: really OK to suppress? - (compiler-warn - "The type ~S ~A conflicts with an enclosing assertion:~% ~S" - (type-specifier atype) - place - (type-specifier old-atype))) - (make-lexenv :type-restrictions `((,cont . ,new-atype)) - :weakend-type-restrictions `((,cont . ,new-ctype)) - :default lexenv))) +;;; A logic shared among THE and TRULY-THE. +(defun the-in-policy (type value policy start next result) + (let ((type (if (ctype-p type) type + (compiler-values-specifier-type type)))) + (cond ((or (eq type *wild-type*) + (eq type *universal-type*) + (and (leaf-p value) + (values-subtypep (make-single-value-type (leaf-type value)) + type)) + (and (sb!xc:constantp value) + (ctypep (constant-form-value value) + (single-value-type type)))) + (ir1-convert start next result value)) + (t (let ((value-ctran (make-ctran)) + (value-lvar (make-lvar))) + (ir1-convert start value-ctran value-lvar value) + (let ((cast (make-cast value-lvar type policy))) + (link-node-to-previous-ctran cast value-ctran) + (setf (lvar-dest value-lvar) cast) + (use-continuation cast next result))))))) ;;; Assert that FORM evaluates to the specified type (which may be a -;;; VALUES type). -;;; -;;; FIXME: In a version of CMU CL that I used at Cadabra ca. 20000101, -;;; this didn't seem to expand into an assertion, at least for ALIEN -;;; values. Check that SBCL doesn't have this problem. -(def-ir1-translator the ((type value) start cont) - (with-continuation-type-assertion (cont (compiler-values-specifier-type type) - "in THE declaration") - (ir1-convert start cont value))) +;;; VALUES type). TYPE may be a type specifier or (as a hack) a CTYPE. +(def-ir1-translator the ((type value) start next result) + (the-in-policy type value (lexenv-policy *lexenv*) start next result)) ;;; This is like the THE special form, except that it believes ;;; whatever you tell it. It will never generate a type check, but ;;; will cause a warning if the compiler can prove the assertion is ;;; wrong. -;;; -;;; Since the CONTINUATION-DERIVED-TYPE is computed as the union of -;;; its uses's types, setting it won't work. Instead we must intersect -;;; the type with the uses's DERIVED-TYPE. -(def-ir1-translator truly-the ((type value) start cont) +(def-ir1-translator truly-the ((type value) start next result) #!+sb-doc - (declare (inline member)) - (let ((type (compiler-values-specifier-type type)) - (old (find-uses cont))) - (ir1-convert start cont value) - (do-uses (use cont) - (unless (member use old :test #'eq) - (derive-node-type use type))))) + "" + #-nil + (let ((type (coerce-to-values (compiler-values-specifier-type type))) + (old (when result (find-uses result)))) + (ir1-convert start next result value) + (when result + (do-uses (use result) + (unless (memq use old) + (derive-node-type use type))))) + #+nil + (the-in-policy type value '((type-check . 0)) start cont)) ;;;; SETQ ;;; If there is a definition in LEXENV-VARS, just set that, otherwise ;;; look at the global information. If the name is for a constant, ;;; then error out. -(def-ir1-translator setq ((&whole source &rest things) start cont) +(def-ir1-translator setq ((&whole source &rest things) start next result) (let ((len (length things))) (when (oddp len) (compiler-error "odd number of args to SETQ: ~S" source)) @@ -787,7 +822,7 @@ (when (constant-p leaf) (compiler-error "~S is a constant and thus can't be set." name)) (when (lambda-var-p leaf) - (let ((home-lambda (continuation-home-lambda-or-null start))) + (let ((home-lambda (ctran-home-lambda-or-null start))) (when home-lambda (pushnew leaf (lambda-calls-or-closes home-lambda)))) (when (lambda-var-ignorep leaf) @@ -796,47 +831,49 @@ (compiler-style-warn "~S is being set even though it was declared to be ignored." name))) - (setq-var start cont leaf (second things))) + (setq-var start next result leaf (second things))) (cons (aver (eq (car leaf) 'MACRO)) - (ir1-convert start cont `(setf ,(cdr leaf) ,(second things)))) + ;; FIXME: [Free] type declaration. -- APD, 2002-01-26 + (ir1-convert start next result + `(setf ,(cdr leaf) ,(second things)))) (heap-alien-info - (ir1-convert start cont + (ir1-convert start next result `(%set-heap-alien ',leaf ,(second things)))))) (collect ((sets)) (do ((thing things (cddr thing))) ((endp thing) - (ir1-convert-progn-body start cont (sets))) + (ir1-convert-progn-body start next result (sets))) (sets `(setq ,(first thing) ,(second thing)))))))) ;;; This is kind of like REFERENCE-LEAF, but we generate a SET node. ;;; This should only need to be called in SETQ. -(defun setq-var (start cont var value) - (declare (type continuation start cont) (type basic-var var)) - (let ((dest (make-continuation))) - (ir1-convert start dest value) - (assert-continuation-type dest - (or (lexenv-find var type-restrictions) - (leaf-type var)) - (lexenv-policy *lexenv*)) - (let ((res (make-set :var var :value dest))) - (setf (continuation-dest dest) res) +(defun setq-var (start next result var value) + (declare (type ctran start next) (type (or lvar null) result) + (type basic-var var)) + (let ((dest-ctran (make-ctran)) + (dest-lvar (make-lvar)) + (type (or (lexenv-find var type-restrictions) + (leaf-type var)))) + (ir1-convert start dest-ctran dest-lvar `(the ,type ,value)) + (let ((res (make-set :var var :value dest-lvar))) + (setf (lvar-dest dest-lvar) res) (setf (leaf-ever-used var) t) (push res (basic-var-sets var)) - (link-node-to-previous-continuation res dest) - (use-continuation res cont)))) + (link-node-to-previous-ctran res dest-ctran) + (use-continuation res next result)))) ;;;; CATCH, THROW and UNWIND-PROTECT ;;; We turn THROW into a MULTIPLE-VALUE-CALL of a magical function, ;;; since as as far as IR1 is concerned, it has no interesting ;;; properties other than receiving multiple-values. -(def-ir1-translator throw ((tag result) start cont) +(def-ir1-translator throw ((tag result) start next result-lvar) #!+sb-doc "Throw Tag Form Do a non-local exit, return the values of Form from the CATCH whose tag evaluates to the same thing as Tag." - (ir1-convert start cont + (ir1-convert start next result-lvar `(multiple-value-call #'%throw ,tag ,result))) ;;; This is a special special form used to instantiate a cleanup as @@ -846,18 +883,19 @@ ;;; and introduce the cleanup into the lexical environment. We ;;; back-patch the ENTRY-CLEANUP for the current cleanup to be the new ;;; cleanup, since this inner cleanup is the interesting one. -(def-ir1-translator %within-cleanup ((kind mess-up &body body) start cont) - (let ((dummy (make-continuation)) - (dummy2 (make-continuation))) - (ir1-convert start dummy mess-up) - (let* ((mess-node (continuation-use dummy)) +(def-ir1-translator %within-cleanup + ((kind mess-up &body body) start next result) + (let ((dummy (make-ctran)) + (dummy2 (make-ctran))) + (ir1-convert start dummy nil mess-up) + (let* ((mess-node (ctran-use dummy)) (cleanup (make-cleanup :kind kind :mess-up mess-node)) (old-cup (lexenv-cleanup *lexenv*)) (*lexenv* (make-lexenv :cleanup cleanup))) (setf (entry-cleanup (cleanup-mess-up old-cup)) cleanup) - (ir1-convert dummy dummy2 '(%cleanup-point)) - (ir1-convert-progn-body dummy2 cont body)))) + (ir1-convert dummy dummy2 nil '(%cleanup-point)) + (ir1-convert-progn-body dummy2 next result body)))) ;;; This is a special special form that makes an "escape function" ;;; which returns unknown values from named block. We convert the @@ -868,24 +906,27 @@ ;;; ;;; Note that environment analysis replaces references to escape ;;; functions with references to the corresponding NLX-INFO structure. -(def-ir1-translator %escape-fun ((tag) start cont) - (let ((fun (ir1-convert-lambda - `(lambda () - (return-from ,tag (%unknown-values))) - :debug-name (debug-namify "escape function for ~S" tag)))) +(def-ir1-translator %escape-fun ((tag) start next result) + (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 cont 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 ;;; referencing it. -(def-ir1-translator %cleanup-fun ((name) start cont) +(def-ir1-translator %cleanup-fun ((name) start next result) (let ((fun (lexenv-find name funs))) (aver (lambda-p fun)) (setf (functional-kind fun) :cleanup) - (reference-leaf start cont fun))) + (reference-leaf start next result fun))) -(def-ir1-translator catch ((tag &body body) start cont) +(def-ir1-translator catch ((tag &body body) start next result) #!+sb-doc "Catch Tag Form* Evaluate TAG and instantiate it as a catcher while the body forms are @@ -896,15 +937,15 @@ ;; "escape function" that does a lexical exit, and instantiate the ;; cleanup using %WITHIN-CLEANUP. (ir1-convert - start cont + start next result (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 cont) +(def-ir1-translator unwind-protect + ((protected &body cleanup) start next result) #!+sb-doc "Unwind-Protect Protected Cleanup* Evaluate the form PROTECTED, returning its values. The CLEANUP forms are @@ -917,7 +958,7 @@ ;; %UNWIND-PROTECT isn't "real", and thus doesn't cause creation of ;; an XEP. (ir1-convert - start cont + start next result (with-unique-names (cleanup-fun drop-thru-tag exit-tag next start count) `(flet ((,cleanup-fun () ,@cleanup nil)) ;; FIXME: If we ever get DYNAMIC-EXTENT working, then @@ -937,91 +978,51 @@ ;;;; multiple-value stuff -(def-ir1-translator multiple-value-call ((fun &rest args) start cont) +(def-ir1-translator multiple-value-call ((fun &rest args) start next result) #!+sb-doc "MULTIPLE-VALUE-CALL Function Values-Form* Call FUNCTION, passing all the values of each VALUES-FORM as arguments, values from the first VALUES-FORM making up the first argument, etc." - (let* ((fun-cont (make-continuation)) + (let* ((ctran (make-ctran)) + (fun-lvar (make-lvar)) (node (if args ;; If there are arguments, MULTIPLE-VALUE-CALL ;; turns into an MV-COMBINATION. - (make-mv-combination fun-cont) + (make-mv-combination fun-lvar) ;; If there are no arguments, then we convert to a ;; normal combination, ensuring that a MV-COMBINATION ;; always has at least one argument. This can be ;; regarded as an optimization, but it is more ;; important for simplifying compilation of ;; MV-COMBINATIONS. - (make-combination fun-cont)))) - (ir1-convert start fun-cont + (make-combination fun-lvar)))) + (ir1-convert start ctran fun-lvar (if (and (consp fun) (eq (car fun) 'function)) fun `(%coerce-callable-to-fun ,fun))) - (setf (continuation-dest fun-cont) node) - (collect ((arg-conts)) - (let ((this-start fun-cont)) + (setf (lvar-dest fun-lvar) node) + (collect ((arg-lvars)) + (let ((this-start ctran)) (dolist (arg args) - (let ((this-cont (make-continuation node))) - (ir1-convert this-start this-cont arg) - (setq this-start this-cont) - (arg-conts this-cont))) - (link-node-to-previous-continuation node this-start) - (use-continuation node cont) - (setf (basic-combination-args node) (arg-conts)))))) - -;;; MULTIPLE-VALUE-PROG1 is represented implicitly in IR1 by having a -;;; the result code use result continuation (CONT), but transfer -;;; control to the evaluation of the body. In other words, the result -;;; continuation isn't IMMEDIATELY-USED-P by the nodes that compute -;;; the result. -;;; -;;; In order to get the control flow right, we convert the result with -;;; a dummy result continuation, then convert all the uses of the -;;; dummy to be uses of CONT. If a use is an EXIT, then we also -;;; substitute CONT for the dummy in the corresponding ENTRY node so -;;; that they are consistent. Note that this doesn't amount to -;;; changing the exit target, since the control destination of an exit -;;; is determined by the block successor; we are just indicating the -;;; continuation that the result is delivered to. -;;; -;;; We then convert the body, using another dummy continuation in its -;;; own block as the result. After we are done converting the body, we -;;; move all predecessors of the dummy end block to CONT's block. -;;; -;;; Note that we both exploit and maintain the invariant that the CONT -;;; to an IR1 convert method either has no block or starts the block -;;; that control should transfer to after completion for the form. -;;; Nested MV-PROG1's work because during conversion of the result -;;; form, we use dummy continuation whose block is the true control -;;; destination. -(def-ir1-translator multiple-value-prog1 ((result &rest forms) start cont) + (let ((this-ctran (make-ctran)) + (this-lvar (make-lvar node))) + (ir1-convert this-start this-ctran this-lvar arg) + (setq this-start this-ctran) + (arg-lvars this-lvar))) + (link-node-to-previous-ctran node this-start) + (use-continuation node next result) + (setf (basic-combination-args node) (arg-lvars)))))) + +(def-ir1-translator multiple-value-prog1 + ((values-form &rest forms) start next result) #!+sb-doc "MULTIPLE-VALUE-PROG1 Values-Form Form* Evaluate Values-Form and then the Forms, but return all the values of Values-Form." - (continuation-starts-block cont) - (let* ((dummy-result (make-continuation)) - (dummy-start (make-continuation)) - (cont-block (continuation-block cont))) - (continuation-starts-block dummy-start) - (ir1-convert start dummy-start result) - - (with-continuation-type-assertion - ;; FIXME: policy - (cont (continuation-asserted-type dummy-start) - "of the first form") - (substitute-continuation-uses cont dummy-start)) - - (continuation-starts-block dummy-result) - (ir1-convert-progn-body dummy-start dummy-result forms) - (let ((end-block (continuation-block dummy-result))) - (dolist (pred (block-pred end-block)) - (unlink-blocks pred end-block) - (link-blocks pred cont-block)) - (aver (not (continuation-dest dummy-result))) - (delete-continuation dummy-result) - (remove-from-dfo end-block)))) + (let ((dummy (make-ctran))) + (ctran-starts-block dummy) + (ir1-convert start dummy result values-form) + (ir1-convert-progn-body dummy next nil forms))) ;;;; interface to defining macros