X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=305306949503c8e5bb5d78dbcd00118a35d8001d;hb=c713eb2b521b048ff2c927ec52b861787d289f85;hp=5f12ea21fe1171e184accd4bd1c7592d5be30c1b;hpb=419ce099442b9bffe41eff8516c6a2be085259de;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 5f12ea2..3053069 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -37,7 +37,7 @@ :alternative else-block))) (setf (continuation-dest pred) node) (ir1-convert start pred test) - (prev-link node pred) + (link-node-to-previous-continuation node pred) (use-continuation node dummy-cont) (let ((start-block (continuation-block pred))) @@ -45,15 +45,15 @@ (continuation-starts-block cont) (link-blocks start-block then-block) - (link-blocks start-block else-block) + (link-blocks start-block else-block)) - (ir1-convert then-cont cont then) - (ir1-convert else-cont cont else)))) + (ir1-convert then-cont cont then) + (ir1-convert else-cont cont else))) ;;;; BLOCK and TAGBODY -;;;; We make an Entry node to mark the start and a :Entry cleanup to -;;;; mark its extent. When doing GO or RETURN-FROM, we emit an Exit +;;;; We make an ENTRY node to mark the start and a :ENTRY cleanup to +;;;; mark its extent. When doing GO or RETURN-FROM, we emit an EXIT ;;;; node. ;;; Make a :ENTRY cleanup and emit an ENTRY node, then convert the @@ -75,7 +75,7 @@ :mess-up entry))) (push entry (lambda-entries (lexenv-lambda *lexenv*))) (setf (entry-cleanup entry) cleanup) - (prev-link entry start) + (link-node-to-previous-continuation entry start) (use-continuation entry dummy) (let* ((env-entry (list entry cont)) @@ -85,16 +85,26 @@ (ir1-convert-progn-body dummy cont forms)))) -;;; 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. -(def-ir1-translator return-from ((name &optional value) - start cont) +(def-ir1-translator return-from ((name &optional value) start cont) #!+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. + ;; 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 + ;; the (SETQ X 3) in?" when the right answer is that (SETQ X 3) is + ;; dead code and so doesn't really have a block at all. The existence + ;; of this block, and that way that it doesn't explicitly say + ;; "I'm actually nowhere at all" makes some logic (e.g. + ;; 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) (let* ((found (or (lexenv-find name blocks) (compiler-error "return for unknown block: ~S" name))) @@ -105,7 +115,10 @@ (push exit (entry-exits entry)) (setf (continuation-dest value-cont) exit) (ir1-convert start value-cont value) - (prev-link exit value-cont) + (link-node-to-previous-continuation exit value-cont) + (let ((home-lambda (continuation-home-lambda-or-null start))) + (when home-lambda + (push entry (lambda-calls-or-closes home-lambda)))) (use-continuation exit (second found)))) ;;; Return a list of the segments of a TAGBODY. Each segment looks @@ -156,7 +169,7 @@ :mess-up entry))) (push entry (lambda-entries (lexenv-lambda *lexenv*))) (setf (entry-cleanup entry) cleanup) - (prev-link entry start) + (link-node-to-previous-continuation entry start) (use-continuation entry dummy) (collect ((tags) @@ -186,11 +199,15 @@ is constrained to be used only within the dynamic extent of the TAGBODY." (continuation-starts-block cont) (let* ((found (or (lexenv-find tag tags :test #'eql) - (compiler-error "Go to nonexistent tag: ~S." tag))) + (compiler-error "attempt to GO to nonexistent tag: ~S" + tag))) (entry (first found)) (exit (make-exit :entry entry))) (push exit (entry-exits entry)) - (prev-link exit start) + (link-node-to-previous-continuation exit start) + (let ((home-lambda (continuation-home-lambda-or-null start))) + (when home-lambda + (push entry (lambda-calls-or-closes home-lambda)))) (use-continuation exit (second found)))) ;;;; translators for compiler-magic special forms @@ -227,11 +244,11 @@ definitions fun) (declare (type function definitionize-fun fun)) - (declare (type (member :variables :functions) definitionize-keyword)) + (declare (type (member :vars :funs) definitionize-keyword)) (declare (type list definitions)) (unless (= (length definitions) (length (remove-duplicates definitions :key #'first))) - (compiler-style-warning "duplicate definitions in ~S" definitions)) + (compiler-style-warn "duplicate definitions in ~S" definitions)) (let* ((processed-definitions (mapcar definitionize-fun definitions)) (*lexenv* (make-lexenv definitionize-keyword processed-definitions))) (funcall fun))) @@ -261,7 +278,7 @@ `(lambda (,whole ,environment) ,@local-decls (block ,name ,body)))))))) - :functions + :funs definitions fun)) @@ -287,7 +304,7 @@ "The local symbol macro name ~S is not a symbol." name)) `(,name . (MACRO . ,expansion)))) - :variables + :vars definitions fun)) @@ -339,39 +356,32 @@ ;;; 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) - (unless (symbolp name) - (compiler-error "internal error: Primitive name ~S is not a symbol." name)) + (declare (type symbol name)) (let* ((template (or (gethash name *backend-template-names*) - (compiler-error - "internal error: Primitive name ~A is not defined." - name))) + (bug "undefined primitive ~A" name))) (required (length (template-arg-types template))) (info (template-info-arg-count template)) (min (+ required info)) (nargs (length args))) (if (template-more-args-type template) (when (< nargs min) - (compiler-error "internal error: Primitive ~A was called ~ - with ~R argument~:P, ~ - but wants at least ~R." - name - nargs - min)) + (bug "Primitive ~A was called with ~R argument~:P, ~ + but wants at least ~R." + name + nargs + min)) (unless (= nargs min) - (compiler-error "internal error: Primitive ~A was called ~ - with ~R argument~:P, ~ - but wants exactly ~R." - name - nargs - min))) + (bug "Primitive ~A was called with ~R argument~:P, ~ + but wants exactly ~R." + name + nargs + min))) (when (eq (template-result-types template) :conditional) - (compiler-error - "%PRIMITIVE was used with a conditional template.")) + (bug "%PRIMITIVE was used with a conditional template.")) (when (template-more-results-type template) - (compiler-error - "%PRIMITIVE was used with an unknown values template.")) + (bug "%PRIMITIVE was used with an unknown values template.")) (ir1-convert start cont @@ -381,19 +391,21 @@ ,@(subseq args 0 required) ,@(subseq args min))))) -;;;; QUOTE and FUNCTION +;;;; QUOTE (def-ir1-translator quote ((thing) start cont) #!+sb-doc "QUOTE Value Return Value without evaluating it." (reference-constant start cont thing)) + +;;;; FUNCTION and NAMED-LAMBDA (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." + be a lambda expression." (if (consp thing) (case (car thing) ((lambda) @@ -403,7 +415,7 @@ :debug-name (debug-namify "#'~S" thing)))) ((setf) - (let ((var (find-lexically-apparent-function + (let ((var (find-lexically-apparent-fun thing "as the argument to FUNCTION"))) (reference-leaf start cont var))) ((instance-lambda) @@ -414,9 +426,40 @@ (reference-leaf start cont res))) (t (compiler-error "~S is not a legal function name." thing))) - (let ((var (find-lexically-apparent-function + (let ((var (find-lexically-apparent-fun thing "as the argument to FUNCTION"))) (reference-leaf start cont var)))) + +;;; `(NAMED-LAMBDA ,NAME ,@REST) is like `(FUNCTION (LAMBDA ,@REST)), +;;; except that the value of NAME is passed to the compiler for use in +;;; creation of debug information for the resulting function. +;;; +;;; NAME can be a legal function name or some arbitrary other thing. +;;; +;;; If NAME is a legal function name, then the caller should be +;;; planning to set (FDEFINITION NAME) to the created function. +;;; (Otherwise the debug names will be inconsistent and thus +;;; unnecessarily confusing.) +;;; +;;; Arbitrary other things are appropriate for naming things which are +;;; not the FDEFINITION of NAME. E.g. +;;; NAME = (:FLET FOO BAR) +;;; for the FLET function in +;;; (DEFUN BAR (X) +;;; (FLET ((FOO (Y) (+ X Y))) +;;; FOO)) +;;; or +;;; NAME = (:METHOD PRINT-OBJECT :AROUND (STARSHIP T)) +;;; for the function used to implement +;;; (DEFMETHOD PRINT-OBJECT :AROUND ((SS STARSHIP) STREAM) ...). +(def-ir1-translator named-lambda ((name &rest rest) start cont) + (reference-leaf start + cont + (if (legal-fun-name-p name) + (ir1-convert-lambda `(lambda ,@rest) + :source-name name) + (ir1-convert-lambda `(lambda ,@rest) + :debug-name name)))) ;;;; FUNCALL @@ -442,7 +485,7 @@ ;;; compiler. If the called function is a FUNCTION form, then convert ;;; directly to %FUNCALL, instead of waiting around for type ;;; inference. -(def-source-transform funcall (function &rest args) +(define-source-transform funcall (function &rest args) (if (and (consp function) (eq (car function) 'function)) `(%funcall ,function ,@args) (values nil t))) @@ -459,16 +502,16 @@ ;;;; any pervasive declarations also affect the evaluation of the ;;;; arguments.) -;;; Given a list of binding specifiers in the style of Let, return: +;;; Given a list of binding specifiers in the style of LET, return: ;;; 1. The list of var structures for the variables bound. ;;; 2. The initial value form for each variable. ;;; ;;; The variable names are checked for legality and globally special ;;; variables are marked as such. Context is the name of the form, for ;;; error reporting purposes. -(declaim (ftype (function (list symbol) (values list list list)) - extract-let-variables)) -(defun extract-let-variables (bindings context) +(declaim (ftype (function (list symbol) (values list list)) + extract-let-vars)) +(defun extract-let-vars (bindings context) (collect ((vars) (vals) (names)) @@ -481,7 +524,7 @@ (cond ((atom spec) (let ((var (get-var spec))) (vars var) - (names (cons spec var)) + (names spec) (vals nil))) (t (unless (proper-list-of-length-p spec 1 2) @@ -494,7 +537,7 @@ (names name) (vals (second spec))))))) - (values (vars) (vals) (names)))) + (values (vars) (vals)))) (def-ir1-translator let ((bindings &body body) start cont) @@ -504,13 +547,14 @@ Value forms. The variables are bound in parallel after all of the Values are evaluated." (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) - (multiple-value-bind (vars values) (extract-let-variables bindings 'let) - (let* ((*lexenv* (process-decls decls vars nil cont)) - (fun-cont (make-continuation)) - (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))))) + (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))))) (def-ir1-translator let* ((bindings &body body) start cont) @@ -519,7 +563,7 @@ 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) (sb!sys:parse-body body nil) - (multiple-value-bind (vars values) (extract-let-variables bindings 'let*) + (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))))) @@ -552,9 +596,8 @@ ;;; ;;; The function names are checked for legality. CONTEXT is the name ;;; of the form, for error reporting. -(declaim (ftype (function (list symbol) (values list list)) - extract-flet-variables)) -(defun extract-flet-variables (definitions context) +(declaim (ftype (function (list symbol) (values list list)) extract-flet-vars)) +(defun extract-flet-vars (definitions context) (collect ((names) (defs)) (dolist (def definitions) @@ -580,7 +623,7 @@ the lexically apparent function definition in the enclosing environment." (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) (multiple-value-bind (names defs) - (extract-flet-variables definitions 'flet) + (extract-flet-vars definitions 'flet) (let* ((fvars (mapcar (lambda (n d) (ir1-convert-lambda d :source-name n @@ -589,7 +632,7 @@ names defs)) (*lexenv* (make-lexenv :default (process-decls decls nil fvars cont) - :functions (pairlis names fvars)))) + :funs (pairlis names fvars)))) (ir1-convert-progn-body start cont forms))))) (def-ir1-translator labels ((definitions &body body) start cont) @@ -600,7 +643,7 @@ each other." (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) (multiple-value-bind (names defs) - (extract-flet-variables 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) @@ -615,8 +658,7 @@ ;; the real LABELS functions, compiled in a LEXENV which ;; includes the dummy LABELS functions (real-funs - (let ((*lexenv* (make-lexenv - :functions placeholder-fenv))) + (let ((*lexenv* (make-lexenv :funs placeholder-fenv))) (mapcar (lambda (name def) (ir1-convert-lambda def :source-name name @@ -638,7 +680,7 @@ ;; placeholder used earlier) so that if the ;; lexical environment is used for inline ;; expansion we'll get the right functions. - :functions (pairlis names real-funs)))) + :funs (pairlis names real-funs)))) (ir1-convert-progn-body start cont forms)))))) ;;;; the THE special operator, and friends @@ -675,7 +717,7 @@ ;;; 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 do-the-stuff (type cont lexenv name) +(defun ir1ize-the-or-values (type cont lexenv name) (declare (type continuation cont) (type lexenv lexenv)) (let* ((ctype (values-specifier-type type)) (old-type (or (lexenv-find cont type-restrictions) @@ -688,8 +730,9 @@ (when (and (not intersects) (not (policy *lexenv* (= inhibit-warnings 3)))) ;FIXME: really OK to suppress? - (compiler-warning - "The type ~S in ~S declaration conflicts with an enclosing assertion:~% ~S" + (compiler-warn + "The type ~S in ~S declaration conflicts with an ~ + enclosing assertion:~% ~S" (type-specifier ctype) name (type-specifier old-type))) @@ -703,7 +746,7 @@ ;;; 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) - (let ((*lexenv* (do-the-stuff type cont *lexenv* 'the))) + (let ((*lexenv* (ir1ize-the-or-values type cont *lexenv* 'the))) (ir1-convert start cont value))) ;;; This is like the THE special form, except that it believes @@ -726,29 +769,32 @@ ;;;; SETQ -;;; If there is a definition in LEXENV-VARIABLES, just set that, -;;; otherwise look at the global information. If the name is for a -;;; constant, then error out. +;;; 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) (let ((len (length things))) (when (oddp len) (compiler-error "odd number of args to SETQ: ~S" source)) (if (= len 2) (let* ((name (first things)) - (leaf (or (lexenv-find name variables) - (find-free-variable name)))) + (leaf (or (lexenv-find name vars) + (find-free-var name)))) (etypecase leaf (leaf (when (constant-p leaf) (compiler-error "~S is a constant and thus can't be set." name)) - (when (and (lambda-var-p leaf) - (lambda-var-ignorep leaf)) - ;; ANSI's definition of "Declaration IGNORE, IGNORABLE" - ;; requires that this be a STYLE-WARNING, not a full warning. - (compiler-style-warning - "~S is being set even though it was declared to be ignored." - name)) - (set-variable start cont leaf (second things))) + (when (lambda-var-p leaf) + (let ((home-lambda (continuation-home-lambda-or-null start))) + (when home-lambda + (pushnew leaf (lambda-calls-or-closes home-lambda)))) + (when (lambda-var-ignorep leaf) + ;; ANSI's definition of "Declaration IGNORE, IGNORABLE" + ;; requires that this be a STYLE-WARNING, not a full warning. + (compiler-style-warn + "~S is being set even though it was declared to be ignored." + name))) + (setq-var start cont leaf (second things))) (cons (aver (eq (car leaf) 'MACRO)) (ir1-convert start cont `(setf ,(cdr leaf) ,(second things)))) @@ -763,7 +809,7 @@ ;;; This is kind of like REFERENCE-LEAF, but we generate a SET node. ;;; This should only need to be called in SETQ. -(defun set-variable (start cont var value) +(defun setq-var (start cont var value) (declare (type continuation start cont) (type basic-var var)) (let ((dest (make-continuation))) (setf (continuation-asserted-type dest) (leaf-type var)) @@ -772,7 +818,7 @@ (setf (continuation-dest dest) res) (setf (leaf-ever-used var) t) (push res (basic-var-sets var)) - (prev-link res dest) + (link-node-to-previous-continuation res dest) (use-continuation res cont)))) ;;;; CATCH, THROW and UNWIND-PROTECT @@ -817,7 +863,7 @@ ;;; ;;; Note that environment analysis replaces references to escape ;;; functions with references to the corresponding NLX-INFO structure. -(def-ir1-translator %escape-function ((tag) start cont) +(def-ir1-translator %escape-fun ((tag) start cont) (let ((fun (ir1-convert-lambda `(lambda () (return-from ,tag (%unknown-values))) @@ -828,8 +874,8 @@ ;;; 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-function ((name) start cont) - (let ((fun (lexenv-find name functions))) +(def-ir1-translator %cleanup-fun ((name) start cont) + (let ((fun (lexenv-find name funs))) (aver (lambda-p fun)) (setf (functional-kind fun) :cleanup) (reference-leaf start cont fun))) @@ -850,13 +896,13 @@ `(block ,exit-block (%within-cleanup :catch - (%catch (%escape-function ,exit-block) ,tag) + (%catch (%escape-fun ,exit-block) ,tag) ,@body))))) ;;; UNWIND-PROTECT is similar to CATCH, but hairier. We make the ;;; cleanup forms into a local function so that they can be referenced ;;; both in the case where we are unwound and in any local exits. We -;;; use %CLEANUP-FUNCTION on this to indicate that reference by +;;; use %CLEANUP-FUN on this to indicate that reference by ;;; %UNWIND-PROTECT isn't "real", and thus doesn't cause creation of ;;; an XEP. (def-ir1-translator unwind-protect ((protected &body cleanup) start cont) @@ -876,15 +922,15 @@ `(flet ((,cleanup-fun () ,@cleanup nil)) ;; FIXME: If we ever get DYNAMIC-EXTENT working, then ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT, - ;; and something can be done to make %ESCAPE-FUNCTION have + ;; and something can be done to make %ESCAPE-FUN have ;; dynamic extent too. (block ,drop-thru-tag (multiple-value-bind (,next ,start ,count) (block ,exit-tag (%within-cleanup :unwind-protect - (%unwind-protect (%escape-function ,exit-tag) - (%cleanup-function ,cleanup-fun)) + (%unwind-protect (%escape-fun ,exit-tag) + (%cleanup-fun ,cleanup-fun)) (return-from ,drop-thru-tag ,protected))) (,cleanup-fun) (%continue-unwind ,next ,start ,count))))))) @@ -921,7 +967,7 @@ (ir1-convert this-start this-cont arg) (setq this-start this-cont) (arg-conts this-cont))) - (prev-link node this-start) + (link-node-to-previous-continuation node this-start) (use-continuation node cont) (setf (basic-combination-args node) (arg-conts)))))) @@ -1027,9 +1073,9 @@ (ecase (info :function :kind name) ((nil)) (:function - (remhash name *free-functions*) + (remhash name *free-funs*) (undefine-fun-name name) - (compiler-warning + (compiler-warn "~S is being redefined as a macro when it was ~ previously ~(~A~) to be a function." name