X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=e188acbbcff1cbe88f35bfbfdf540f0b004d06e5;hb=c41cb4c87eae7b04f844dca5f7edb5086c5d2d68;hp=a1c9556a989f81775a5f6a6991575798d4827428;hpb=d40a76606c86722b0aef8179155f9f2840739b72;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index a1c9556..e188acb 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -12,7 +12,7 @@ (in-package "SB!C") -;;;; control special forms +;;;; special forms for control (def-ir1-translator progn ((&rest forms) start cont) #!+sb-doc @@ -35,6 +35,8 @@ (node (make-if :test pred :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) @@ -77,14 +79,13 @@ (setf (entry-cleanup entry) cleanup) (link-node-to-previous-continuation entry start) (use-continuation entry dummy) - + (let* ((env-entry (list entry cont)) (*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)))) - (def-ir1-translator return-from ((name &optional value) start cont) #!+sb-doc "Return-From Block-Name Value-Form @@ -178,7 +179,7 @@ (starts dummy) (dolist (segment (rest segments)) (let* ((tag-cont (make-continuation)) - (tag (list (car segment) entry tag-cont))) + (tag (list (car segment) entry tag-cont))) (conts tag-cont) (starts tag-cont) (continuation-starts-block tag-cont) @@ -223,7 +224,7 @@ ;;; are ignored for non-top-level forms. For non-top-level forms, an ;;; 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. +;;; form; otherwise, the forms in the body are ignored. (def-ir1-translator eval-when ((situations &rest forms) start cont) #!+sb-doc "EVAL-WHEN (Situation*) Form* @@ -244,41 +245,55 @@ 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-warn "duplicate definitions in ~S" definitions)) (let* ((processed-definitions (mapcar definitionize-fun definitions)) (*lexenv* (make-lexenv definitionize-keyword processed-definitions))) - (funcall fun))) + (funcall fun definitionize-keyword processed-definitions))) -;;; Tweak *LEXENV* to include the DEFINITIONS from a MACROLET, then +;;; Tweak LEXENV to include the DEFINITIONS from a MACROLET, then ;;; call FUN (with no arguments). ;;; ;;; This is split off from the IR1 convert method so that it can be -;;; shared by the special-case top level MACROLET processing code. -(defun funcall-in-macrolet-lexenv (definitions fun) +;;; 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. +(defun macrolet-definitionize-fun (context lexenv) + (flet ((fail (control &rest args) + (ecase context + (: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) + (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) + (fail "The local macro name ~S is not a symbol." name)) + (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 - (lambda (definition) - (unless (list-of-length-at-least-p definition 2) - (compiler-error - "The list ~S is too short to be a legal local macro definition." - definition)) - (destructuring-bind (name arglist &body body) definition - (unless (symbolp name) - (compiler-error "The local macro name ~S is not a symbol." name)) - (let ((whole (gensym "WHOLE")) - (environment (gensym "ENVIRONMENT"))) - (multiple-value-bind (body local-decls) - (parse-defmacro arglist whole body name 'macrolet - :environment environment) - `(,name macro . - ,(compile nil - `(lambda (,whole ,environment) - ,@local-decls - (block ,name ,body)))))))) - :functions + (macrolet-definitionize-fun context (make-restricted-lexenv *lexenv*)) + :funs definitions fun)) @@ -287,27 +302,40 @@ "MACROLET ({(Name Lambda-List Form*)}*) Body-Form* Evaluate the Body-Forms in an environment with the specified local macros defined. Name is the local macro name, Lambda-List is the DEFMACRO style - destructuring lambda list, and the Forms evaluate to the expansion. The - Forms are evaluated in the null environment." - (funcall-in-macrolet-lexenv definitions - (lambda () - (ir1-translate-locally body start cont)))) - -(defun funcall-in-symbol-macrolet-lexenv (definitions fun) + destructuring lambda list, and the Forms evaluate to the expansion.." + (funcall-in-macrolet-lexenv + definitions + (lambda (&key funs) + (declare (ignore funs)) + (ir1-translate-locally body start cont)) + :compile)) + +(defun symbol-macrolet-definitionize-fun (context) + (flet ((fail (control &rest args) + (ecase context + (: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) + (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)) + (let ((kind (info :variable :kind name))) + (when (member kind '(:special :constant)) + (fail "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S" + kind name))) + `(,name . (MACRO . ,expansion)))))) + +(defun funcall-in-symbol-macrolet-lexenv (definitions fun context) (%funcall-in-foomacrolet-lexenv - (lambda (definition) - (unless (proper-list-of-length-p definition 2) - (compiler-error "malformed symbol/expansion pair: ~S" definition)) - (destructuring-bind (name expansion) definition - (unless (symbolp name) - (compiler-error - "The local symbol macro name ~S is not a symbol." - name)) - `(,name . (MACRO . ,expansion)))) - :variables + (symbol-macrolet-definitionize-fun context) + :vars definitions fun)) - + (def-ir1-translator symbol-macrolet ((macrobindings &body body) start cont) #!+sb-doc "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form* @@ -315,17 +343,9 @@ body, references to a Name will effectively be replaced with the Expansion." (funcall-in-symbol-macrolet-lexenv macrobindings - (lambda () - (ir1-translate-locally body start cont)))) - -;;; not really a special form, but.. -(def-ir1-translator declare ((&rest stuff) start cont) - (declare (ignore stuff)) - ;; We ignore START and CONT too, but we can't use DECLARE IGNORE to - ;; tell the compiler about it here, because the DEF-IR1-TRANSLATOR - ;; macro would put the DECLARE in the wrong place, so.. - start cont - (compiler-error "misplaced declaration")) + (lambda (&key vars) + (ir1-translate-locally body start cont :vars vars)) + :compile)) ;;;; %PRIMITIVE ;;;; @@ -356,39 +376,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 @@ -407,70 +420,36 @@ (reference-constant start cont thing)) ;;;; FUNCTION and NAMED-LAMBDA +(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 "#'~S" thing) + :allow-debug-catch-tag t)) + ((legal-fun-name-p thing) + (find-lexically-apparent-fun + thing "as the argument to FUNCTION")) + (t + (compiler-error "~S is not a legal function name." thing))) + (find-lexically-apparent-fun + thing "as the argument to FUNCTION"))) (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." - (if (consp thing) - (case (car thing) - ((lambda) - (reference-leaf start - cont - (ir1-convert-lambda thing - :debug-name (debug-namify - "#'~S" thing)))) - ((setf) - (let ((var (find-lexically-apparent-function - thing "as the argument to FUNCTION"))) - (reference-leaf start cont var))) - ((instance-lambda) - (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing)) - :debug-name (debug-namify "#'~S" - thing)))) - (setf (getf (functional-plist res) :fin-function) t) - (reference-leaf start cont res))) - (t - (compiler-error "~S is not a legal function name." thing))) - (let ((var (find-lexically-apparent-function - 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. -;;; -;;; Eventually we might use this for NAME values other than legal -;;; function names, 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 (STARSHIP T)) -;;; for the function used to implement -;;; (DEFMETHOD PRINT-OBJECT ((SS STARSHIP) STREAM) ...). -;;; However, as of this writing (while defining/implementing it in -;;; sbcl-0.pre7.108) NAME is always a legal function name. -;;; -;;; 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.) -(def-ir1-translator named-lambda ((name &rest rest) start cont) - (reference-leaf start - cont - (ir1-convert-lambda `(lambda ,@rest) - :source-name name))) + (reference-leaf start cont (fun-name-leaf thing))) ;;;; FUNCALL ;;; FUNCALL is implemented on %FUNCALL, which can only call functions ;;; (not symbols). %FUNCALL is used directly in some places where the ;;; call should always be open-coded even if FUNCALL is :NOTINLINE. -(deftransform funcall ((function &rest args) * * :when :both) +(deftransform funcall ((function &rest args) * *) (let ((arg-names (make-gensym-list (length args)))) `(lambda (function ,@arg-names) (%funcall ,(if (csubtypep (continuation-type function) @@ -480,10 +459,11 @@ ,@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)) - (ir1-convert-combination-args fun-cont cont args))) + (if (and (consp function) (eq (car function) 'function)) + (ir1-convert start cont `(,(fun-name-leaf (second function)) ,@args)) + (let ((fun-cont (make-continuation))) + (ir1-convert start fun-cont `(the function ,function)) + (ir1-convert-combination-args fun-cont cont args)))) ;;; This source transform exists to reduce the amount of work for the ;;; compiler. If the called function is a FUNCTION form, then convert @@ -495,7 +475,6 @@ (values nil t))) (deftransform %coerce-callable-to-fun ((thing) (function) * - :when :both :important t) "optimize away possible call to FDEFINITION at runtime" 'thing) @@ -506,16 +485,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)) @@ -528,7 +507,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) @@ -541,23 +520,28 @@ (names name) (vals (second spec))))))) - (values (vars) (vals) (names)))) + (values (vars) (vals)))) -(def-ir1-translator let ((bindings &body body) - start cont) +(def-ir1-translator let ((bindings &body body) start cont) #!+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." - (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))))) + (if (null bindings) + (ir1-translate-locally body start cont) + (multiple-value-bind (forms decls) + (parse-body body :doc-string-allowed nil) + (multiple-value-bind (vars values) (extract-let-vars bindings 'let) + (let* ((fun-cont (make-continuation)) + (cont (processing-decls (decls vars nil cont) + (let ((fun (ir1-convert-lambda-body + forms vars + :debug-name (debug-namify "LET ~S" + bindings)))) + (reference-leaf start fun-cont fun)) + cont))) + (ir1-convert-combination-args fun-cont cont values)))))) (def-ir1-translator let* ((bindings &body body) start cont) @@ -565,10 +549,11 @@ "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) (sb!sys:parse-body body nil) - (multiple-value-bind (vars values) (extract-let-variables bindings 'let*) - (let ((*lexenv* (process-decls decls vars nil cont))) - (ir1-convert-aux-bindings start cont forms vars values))))) + (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 cont) + (ir1-convert-aux-bindings start cont forms vars values))))) ;;; logic shared between IR1 translators for LOCALLY, MACROLET, ;;; and SYMBOL-MACROLET @@ -577,11 +562,11 @@ ;;; 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) +(defun ir1-translate-locally (body start cont &key vars funs) (declare (type list body) (type continuation start cont)) - (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) - (let ((*lexenv* (process-decls decls nil nil cont))) - (ir1-convert-aux-bindings start cont forms nil nil)))) + (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) + (processing-decls (decls vars funs cont) + (ir1-convert-progn-body start cont forms)))) (def-ir1-translator locally ((&body body) start cont) #!+sb-doc @@ -599,9 +584,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) @@ -611,7 +595,7 @@ (let ((name (first def))) (check-fun-name name) (names name) - (multiple-value-bind (forms decls) (sb!sys:parse-body (cddr def)) + (multiple-value-bind (forms decls) (parse-body (cddr def)) (defs `(lambda ,(second def) ,@decls (block ,(fun-name-block-name name) @@ -625,19 +609,20 @@ 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) (sb!sys:parse-body body nil) + (multiple-value-bind (forms decls) + (parse-body body :doc-string-allowed nil) (multiple-value-bind (names defs) - (extract-flet-variables definitions 'flet) - (let* ((fvars (mapcar (lambda (n d) - (ir1-convert-lambda d - :source-name n - :debug-name (debug-namify - "FLET ~S" n))) - names defs)) - (*lexenv* (make-lexenv - :default (process-decls decls nil fvars cont) - :functions (pairlis names fvars)))) - (ir1-convert-progn-body start cont forms))))) + (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))) + (processing-decls (decls nil fvars cont) + (let ((*lexenv* (make-lexenv :funs (pairlis names fvars)))) + (ir1-convert-progn-body start cont forms))))))) (def-ir1-translator labels ((definitions &body body) start cont) #!+sb-doc @@ -645,10 +630,10 @@ 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) (sb!sys:parse-body body nil) + (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) (multiple-value-bind (names defs) - (extract-flet-variables 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 @@ -662,13 +647,13 @@ ;; 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 :debug-name (debug-namify - "LABELS ~S" name))) + "LABELS ~S" name) + :allow-debug-catch-tag t)) names defs)))) ;; Modify all the references to the dummy function leaves so @@ -679,112 +664,73 @@ (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. - :functions (pairlis names real-funs)))) - (ir1-convert-progn-body start cont forms)))))) + (processing-decls (decls nil real-funs cont) + (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 cont 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 do-the-stuff (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) - *wild-type*)) - (intersects (values-types-equal-or-intersect old-type ctype)) - (int (values-type-intersection old-type ctype)) - (new (if intersects int old-type))) - (when (null (find-uses cont)) - (setf (continuation-asserted-type cont) new)) - (when (and (not intersects) - (not (policy *lexenv* - (= inhibit-warnings 3)))) ;FIXME: really OK to suppress? - (compiler-warn - "The type ~S in ~S declaration conflicts with an ~ - enclosing assertion:~% ~S" - (type-specifier ctype) - name - (type-specifier old-type))) - (make-lexenv :type-restrictions `((,cont . ,new)) - :default lexenv))) +;;; A logic shared among THE and TRULY-THE. +(defun the-in-policy (type value policy start cont) + (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 cont value)) + (t (let ((value-cont (make-continuation))) + (ir1-convert start value-cont value) + (let ((cast (make-cast value-cont type policy))) + (link-node-to-previous-continuation cast value-cont) + (setf (continuation-dest value-cont) cast) + (use-continuation cast cont))))))) ;;; 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. +;;; VALUES type). TYPE may be a type specifier or (as a hack) a CTYPE. (def-ir1-translator the ((type value) start cont) - (let ((*lexenv* (do-the-stuff type cont *lexenv* 'the))) - (ir1-convert start cont value))) + (the-in-policy type value (lexenv-policy *lexenv*) start cont)) ;;; 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) #!+sb-doc + "" (declare (inline member)) - (let ((type (values-specifier-type type)) + #-nil + (let ((type (coerce-to-values (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))))) + (derive-node-type use type)))) + #+nil + (the-in-policy type value '((type-check . 0)) start cont)) ;;;; 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) @@ -799,9 +745,10 @@ (compiler-style-warn "~S is being set even though it was declared to be ignored." name))) - (set-variable start cont leaf (second things))) + (setq-var start cont leaf (second things))) (cons (aver (eq (car leaf) 'MACRO)) + ;; FIXME: [Free] type declaration. -- APD, 2002-01-26 (ir1-convert start cont `(setf ,(cdr leaf) ,(second things)))) (heap-alien-info (ir1-convert start cont @@ -814,11 +761,12 @@ ;;; 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)) - (ir1-convert start dest value) + (let ((dest (make-continuation)) + (type (or (lexenv-find var type-restrictions) + (leaf-type var)))) + (ir1-convert start dest `(the ,type ,value)) (let ((res (make-set :var var :value dest))) (setf (continuation-dest dest) res) (setf (leaf-ever-used var) t) @@ -828,7 +776,7 @@ ;;;; CATCH, THROW and UNWIND-PROTECT -;;; We turn THROW into a multiple-value-call of a magical function, +;;; 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) @@ -868,7 +816,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))) @@ -879,92 +827,86 @@ ;;; 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))) -;;; We represent the possibility of the control transfer by making an -;;; "escape function" that does a lexical exit, and instantiate the -;;; cleanup using %WITHIN-CLEANUP. (def-ir1-translator catch ((tag &body body) start cont) #!+sb-doc "Catch Tag Form* - Evaluates Tag and instantiates it as a catcher while the body forms are - evaluated in an implicit PROGN. If a THROW is done to Tag within the dynamic + Evaluate TAG and instantiate it as a catcher while the body forms are + evaluated in an implicit PROGN. If a THROW is done to TAG within the dynamic scope of the body, then control will be transferred to the end of the body and the thrown values will be returned." + ;; We represent the possibility of the control transfer by making an + ;; "escape function" that does a lexical exit, and instantiate the + ;; cleanup using %WITHIN-CLEANUP. (ir1-convert start cont - (let ((exit-block (gensym "EXIT-BLOCK-"))) + (with-unique-names (exit-block) `(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 -;;; %UNWIND-PROTECT isn't "real", and thus doesn't cause creation of -;;; an XEP. (def-ir1-translator unwind-protect ((protected &body cleanup) start cont) #!+sb-doc "Unwind-Protect Protected Cleanup* - Evaluate the form Protected, returning its values. The cleanup forms are - evaluated whenever the dynamic scope of the Protected form is exited (either + Evaluate the form PROTECTED, returning its values. The CLEANUP forms are + evaluated whenever the dynamic scope of the PROTECTED form is exited (either due to normal completion or a non-local exit such as THROW)." + ;; 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-FUN on this to indicate that reference by + ;; %UNWIND-PROTECT isn't "real", and thus doesn't cause creation of + ;; an XEP. (ir1-convert start cont - (let ((cleanup-fun (gensym "CLEANUP-FUN-")) - (drop-thru-tag (gensym "DROP-THRU-TAG-")) - (exit-tag (gensym "EXIT-TAG-")) - (next (gensym "NEXT")) - (start (gensym "START")) - (count (gensym "COUNT"))) + (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 ;; ,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))))))) ;;;; multiple-value stuff -;;; If there are arguments, MULTIPLE-VALUE-CALL turns into an -;;; MV-COMBINATION. -;;; -;;; 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. (def-ir1-translator multiple-value-call ((fun &rest args) start cont) #!+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." + 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)) (node (if args + ;; If there are arguments, MULTIPLE-VALUE-CALL + ;; turns into an MV-COMBINATION. (make-mv-combination fun-cont) + ;; 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 (if (and (consp fun) (eq (car fun) 'function)) fun `(%coerce-callable-to-fun ,fun))) (setf (continuation-dest fun-cont) node) - (assert-continuation-type fun-cont - (specifier-type '(or function symbol))) (collect ((arg-conts)) (let ((this-start fun-cont)) (dolist (arg args) @@ -1027,20 +969,17 @@ ;;;; interface to defining macros -;;;; FIXME: -;;;; classic CMU CL comment: -;;;; DEFMACRO and DEFUN expand into calls to %DEFxxx functions -;;;; so that we get a chance to see what is going on. We define -;;;; IR1 translators for these functions which look at the -;;;; definition and then generate a call to the %%DEFxxx function. -;;;; Alas, this implementation doesn't do the right thing for -;;;; non-toplevel uses of these forms, so this should probably -;;;; be changed to use EVAL-WHEN instead. - -;;; Return a new source path with any stuff intervening between the -;;; current path and the first form beginning with NAME stripped off. -;;; This is used to hide the guts of DEFmumble macros to prevent -;;; annoying error messages. +;;; Old CMUCL comment: +;;; +;;; Return a new source path with any stuff intervening between the +;;; current path and the first form beginning with NAME stripped +;;; off. This is used to hide the guts of DEFmumble macros to +;;; prevent annoying error messages. +;;; +;;; Now that we have implementations of DEFmumble macros in terms of +;;; EVAL-WHEN, this function is no longer used. However, it might be +;;; worth figuring out why it was used, and maybe doing analogous +;;; munging to the functions created in the expanders for the macros. (defun revert-source-path (name) (do ((path *current-path* (cdr path))) ((null path) *current-path*) @@ -1048,101 +987,3 @@ (when (or (eq first name) (eq first 'original-source-start)) (return path))))) - -;;; Warn about incompatible or illegal definitions and add the macro -;;; to the compiler environment. -;;; -;;; Someday we could check for macro arguments being incompatibly -;;; redefined. Doing this right will involve finding the old macro -;;; lambda-list and comparing it with the new one. -(def-ir1-translator %defmacro ((qname qdef lambda-list doc) start cont - :kind :function) - (let (;; QNAME is typically a quoted name. I think the idea is to - ;; let %DEFMACRO work as an ordinary function when - ;; interpreting. Whatever the reason the quote is there, we - ;; don't want it any more. -- WHN 19990603 - (name (eval qname)) - ;; QDEF should be a sharp-quoted definition. We don't want to - ;; make a function of it just yet, so we just drop the - ;; sharp-quote. - (def (progn - (aver (eq 'function (first qdef))) - (aver (proper-list-of-length-p qdef 2)) - (second qdef)))) - - (/show "doing IR1 translator for %DEFMACRO" name) - - (unless (symbolp name) - (compiler-error "The macro name ~S is not a symbol." name)) - - (ecase (info :function :kind name) - ((nil)) - (:function - (remhash name *free-functions*) - (undefine-fun-name name) - (compiler-warn - "~S is being redefined as a macro when it was ~ - previously ~(~A~) to be a function." - name - (info :function :where-from name))) - (:macro) - (:special-form - (compiler-error "The special form ~S can't be redefined as a macro." - name))) - - (setf (info :function :kind name) :macro - (info :function :where-from name) :defined - (info :function :macro-function name) (coerce def 'function)) - - (let* ((*current-path* (revert-source-path 'defmacro)) - (fun (ir1-convert-lambda def - :debug-name (debug-namify "DEFMACRO ~S" - name)))) - (setf (functional-arg-documentation fun) (eval lambda-list)) - - (ir1-convert start cont `(%%defmacro ',name ,fun ,doc))) - - (when sb!xc:*compile-print* - ;; FIXME: It would be nice to convert this, and the other places - ;; which create compiler diagnostic output prefixed by - ;; semicolons, to use some common utility which automatically - ;; prefixes all its output with semicolons. (The addition of - ;; semicolon prefixes was introduced ca. sbcl-0.6.8.10 as the - ;; "MNA compiler message patch", and implemented by modifying a - ;; bunch of output statements on a case-by-case basis, which - ;; seems unnecessarily error-prone and unclear, scattering - ;; implicit information about output style throughout the - ;; system.) Starting by rewriting COMPILER-MUMBLE to add - ;; semicolon prefixes would be a good start, and perhaps also: - ;; * Add semicolon prefixes for "FOO assembled" messages emitted - ;; when e.g. src/assembly/x86/assem-rtns.lisp is processed. - ;; * At least some debugger output messages deserve semicolon - ;; prefixes too: - ;; ** restarts table - ;; ** "Within the debugger, you can type HELP for help." - (compiler-mumble "~&; converted ~S~%" name)))) - -(def-ir1-translator %define-compiler-macro ((name def lambda-list doc) - start cont - :kind :function) - (let ((name (eval name)) - (def (second def))) ; We don't want to make a function just yet... - - (when (eq (info :function :kind name) :special-form) - (compiler-error "attempt to define a compiler-macro for special form ~S" - name)) - - (setf (info :function :compiler-macro-function name) - (coerce def 'function)) - - (let* ((*current-path* (revert-source-path 'define-compiler-macro)) - (fun (ir1-convert-lambda def - :debug-name (debug-namify - "DEFINE-COMPILER-MACRO ~S" - name)))) - (setf (functional-arg-documentation fun) (eval lambda-list)) - - (ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc))) - - (when sb!xc:*compile-print* - (compiler-mumble "~&; converted ~S~%" name))))