X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=ce4326bab8d7bc0382dd40c756100bf4de5b5750;hb=7c07a6f965c51828d8f452b47e0620d8e6cf2959;hp=ae11f5ddf3793d54ede1bd9d066482a7a4a57430;hpb=568b75331113ecd0601449f337557cd1c1776e8d;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index ae11f5d..ce4326b 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -48,19 +48,12 @@ (defvar *converting-for-interpreter* nil) ;;; FIXME: Rename to *IR1-FOR-INTERPRETER-NOT-COMPILER-P*. -;;; FIXME: This nastiness was one of my original motivations to start -;;; hacking CMU CL. The non-ANSI behavior can be useful, but it should -;;; be made not the default, and perhaps should be controlled by -;;; DECLAIM instead of a variable like this. And whether or not this -;;; kind of checking is on, declarations should be assertions to the -;;; extent practical, and code which can't be compiled efficiently -;;; while adhering to that principle should give warnings. -(defvar *derive-function-types* t - #!+sb-doc - "(Caution: Soon, this might change its semantics somewhat, or even go away.) - If true, argument and result type information derived from compilation of - DEFUNs is used when compiling calls to that function. If false, only - information from FTYPE proclamations will be used.") +(defvar *derive-function-types* nil + "Should the compiler assume that function types will never change, + so that it can use type information inferred from current definitions + to optimize code which uses those definitions? Setting this true + gives non-ANSI, early-CMU-CL behavior. It can be useful for improving + the efficiency of stable code.") ;;;; namespace management utilities @@ -382,7 +375,7 @@ ;;; This function is called on freshly read forms to record the ;;; initial location of each form (and subform.) Form is the form to -;;; find the paths in, and TLF-Num is the top-level form number of the +;;; find the paths in, and TLF-NUM is the top-level form number of the ;;; truly top-level form. ;;; ;;; This gets a bit interesting when the source code is circular. This @@ -430,8 +423,8 @@ `(block ,skip (catch 'ir1-error-abort (let ((*compiler-error-bailout* - #'(lambda () - (throw 'ir1-error-abort nil)))) + (lambda () + (throw 'ir1-error-abort nil)))) ,@body (return-from ,skip nil))) (ir1-convert ,start ,cont ,proxy))))) @@ -487,7 +480,7 @@ (values)) ;; Generate a reference to a manifest constant, creating a new leaf - ;; if necessary. If we are producing a fasl-file, make sure that + ;; if necessary. If we are producing a fasl file, make sure that ;; MAKE-LOAD-FORM gets used on any parts of the constant that it ;; needs to be. (defun reference-constant (start cont value) @@ -829,7 +822,7 @@ type (type-approx-intersection2 old-type type)))) (cond ((eq int *empty-type*) - (unless (policy nil (= inhibit-warnings 3)) + (unless (policy *lexenv* (= inhibit-warnings 3)) (compiler-warning "The type declarations ~S and ~S for ~S conflict." (type-specifier old-type) (type-specifier type) @@ -937,7 +930,7 @@ name "in an inline or notinline declaration"))) (etypecase found (functional - (when (policy nil (>= speed inhibit-warnings)) + (when (policy *lexenv* (>= speed inhibit-warnings)) (compiler-note "ignoring ~A declaration not at ~ definition of local function:~% ~S" sense name))) @@ -1018,12 +1011,6 @@ (make-lexenv :default res :policy (process-optimize-decl spec (lexenv-policy res)))) - (optimize-interface - (make-lexenv - :default res - :interface-policy (process-optimize-decl - spec - (lexenv-interface-policy res)))) (type (process-type-decl (cdr spec) res vars)) (values @@ -1035,7 +1022,7 @@ `(values ,@types)) cont res 'values)))) (dynamic-extent - (when (policy nil (> speed inhibit-warnings)) + (when (policy *lexenv* (> speed inhibit-warnings)) (compiler-note "compiler limitation:~ ~% There's no special support for DYNAMIC-EXTENT (so it's ignored).")) @@ -1126,7 +1113,7 @@ (declaim (ftype (function (symbol list t) keyword) make-keyword-for-arg)) (defun make-keyword-for-arg (symbol vars keywordify) (let ((key (if (and keywordify (not (keywordp symbol))) - (intern (symbol-name symbol) "KEYWORD") + (keywordicate symbol) symbol))) (when (eq key :allow-other-keys) (compiler-error "No &KEY arg can be called :ALLOW-OTHER-KEYS.")) @@ -1274,26 +1261,18 @@ ;;; sequentially bind each AUX-VAR to the corresponding AUX-VAL before ;;; converting the body. If there are no bindings, just convert the ;;; body, otherwise do one binding and recurse on the rest. -;;; -;;; If INTERFACE is true, then we convert bindings with the interface -;;; policy. For real &AUX bindings, and for implicit aux bindings -;;; introduced by keyword bindings, this is always true. It is only -;;; false when LET* directly calls this function. -(defun ir1-convert-aux-bindings (start cont body aux-vars aux-vals interface) +(defun ir1-convert-aux-bindings (start cont body aux-vars aux-vals) (declare (type continuation start cont) (list body aux-vars aux-vals)) (if (null aux-vars) (ir1-convert-progn-body start cont body) (let ((fun-cont (make-continuation)) - (fun (ir1-convert-lambda-body body (list (first aux-vars)) - (rest aux-vars) (rest aux-vals) - interface))) + (fun (ir1-convert-lambda-body body + (list (first aux-vars)) + :aux-vars (rest aux-vars) + :aux-vals (rest aux-vals)))) (reference-leaf start fun-cont fun) - (let ((*lexenv* (if interface - (make-lexenv - :policy (make-interface-policy *lexenv*)) - *lexenv*))) - (ir1-convert-combination-args fun-cont cont - (list (first aux-vals)))))) + (ir1-convert-combination-args fun-cont cont + (list (first aux-vals))))) (values)) ;;; This is similar to IR1-CONVERT-PROGN-BODY except that code to bind @@ -1307,13 +1286,12 @@ ;;; will end up being the innermost one. We force CONT to start a ;;; block outside of this cleanup, causing cleanup code to be emitted ;;; when the scope is exited. -(defun ir1-convert-special-bindings (start cont body aux-vars aux-vals - interface svars) +(defun ir1-convert-special-bindings (start cont body aux-vars aux-vals svars) (declare (type continuation start cont) (list body aux-vars aux-vals svars)) (cond ((null svars) - (ir1-convert-aux-bindings start cont body aux-vars aux-vals interface)) + (ir1-convert-aux-bindings start cont body aux-vars aux-vals)) (t (continuation-starts-block cont) (let ((cleanup (make-cleanup :kind :special-bind)) @@ -1326,7 +1304,7 @@ (let ((*lexenv* (make-lexenv :cleanup cleanup))) (ir1-convert next-cont nnext-cont '(%cleanup-point)) (ir1-convert-special-bindings nnext-cont cont body aux-vars aux-vals - interface (rest svars)))))) + (rest svars)))))) (values)) ;;; Create a lambda node out of some code, returning the result. The @@ -1345,11 +1323,8 @@ ;;; ;;; AUX-VARS is a list of VAR structures for variables that are to be ;;; sequentially bound. Each AUX-VAL is a form that is to be evaluated -;;; to get the initial value for the corresponding AUX-VAR. Interface -;;; is a flag as T when there are real aux values (see LET* and -;;; IR1-CONVERT-AUX-BINDINGS.) -(defun ir1-convert-lambda-body (body vars &optional aux-vars aux-vals - interface result) +;;; to get the initial value for the corresponding AUX-VAR. +(defun ir1-convert-lambda-body (body vars &key aux-vars aux-vals result) (declare (list body vars aux-vars aux-vals) (type (or continuation null) result)) (let* ((bind (make-bind)) @@ -1381,7 +1356,7 @@ (prev-link bind cont1) (use-continuation bind cont2) (ir1-convert-special-bindings cont2 result body aux-vars aux-vals - interface (svars))) + (svars))) (let ((block (continuation-block result))) (when block @@ -1409,8 +1384,6 @@ ;;; then we mark the corresponding var as EVER-USED to inhibit ;;; "defined but not read" warnings for arguments that are only used ;;; by default forms. -;;; -;;; We bind *LEXENV* to change the policy to the interface policy. (defun convert-optional-entry (fun vars vals defaults) (declare (type clambda fun) (list vars vals defaults)) (let* ((fvars (reverse vars)) @@ -1423,14 +1396,14 @@ :where-from (leaf-where-from var) :specvar (lambda-var-specvar var))) fvars)) - (*lexenv* (make-lexenv :policy (make-interface-policy *lexenv*))) (fun - (ir1-convert-lambda-body - `((%funcall ,fun ,@(reverse vals) ,@defaults)) - arg-vars))) - (mapc #'(lambda (var arg-var) - (when (cdr (leaf-refs arg-var)) - (setf (leaf-ever-used var) t))) + (ir1-convert-lambda-body `((%funcall ,fun + ,@(reverse vals) + ,@defaults)) + arg-vars))) + (mapc (lambda (var arg-var) + (when (cdr (leaf-refs arg-var)) + (setf (leaf-ever-used var) t))) fvars arg-vars) fun)) @@ -1497,10 +1470,6 @@ ;;; ;;; We deal with :ALLOW-OTHER-KEYS by delaying unknown keyword errors ;;; until we have scanned all the keywords. -;;; -;;; When converting the function, we bind *LEXENV* to change the -;;; compilation policy over to the interface policy, so that keyword -;;; args will be checked even when type checking isn't on in general. (defun convert-more-entry (res entry-vars entry-vals rest morep keys) (declare (type optional-dispatch res) (list entry-vars entry-vals keys)) (collect ((arg-vars) @@ -1517,8 +1486,7 @@ (context-temp (make-lambda-var :name n-context)) (n-count (gensym "N-COUNT-")) (count-temp (make-lambda-var :name n-count - :type (specifier-type 'index))) - (*lexenv* (make-lexenv :policy (make-interface-policy *lexenv*)))) + :type (specifier-type 'index)))) (arg-vars context-temp count-temp) @@ -1535,7 +1503,7 @@ (n-allowp (gensym "N-ALLOWP-")) (n-losep (gensym "N-LOSEP-")) (allowp (or (optional-dispatch-allowp res) - (policy nil (zerop safety))))) + (policy *lexenv* (zerop safety))))) (temps `(,n-index (1- ,n-count)) n-key n-value-temp) (body `(declare (fixnum ,n-index) (ignorable ,n-key ,n-value-temp))) @@ -1596,7 +1564,7 @@ (values)) -;;; This is called by IR1-Convert-Hairy-Args when we run into a &REST +;;; This is called by IR1-CONVERT-HAIRY-ARGS when we run into a &REST ;;; or &KEY arg. The arguments are similar to that function, but we ;;; split off any &REST arg and pass it in separately. REST is the ;;; &REST arg var, or NIL if there is no &REST arg. KEYS is a list of @@ -1670,11 +1638,11 @@ (main-vals (arg-info-default info)) (bind-vals n-val))))) - (let* ((main-entry (ir1-convert-lambda-body body (main-vars) - (append (bind-vars) aux-vars) - (append (bind-vals) aux-vals) - t - cont)) + (let* ((main-entry (ir1-convert-lambda-body + body (main-vars) + :aux-vars (append (bind-vars) aux-vars) + :aux-vals (append (bind-vals) aux-vals) + :result cont)) (last-entry (convert-optional-entry main-entry default-vars (main-vals) ()))) (setf (optional-dispatch-main-entry res) main-entry) @@ -1691,29 +1659,30 @@ ;;; arguments, analyzing the arglist on the way down and generating entry ;;; points on the way up. ;;; -;;; Default-Vars is a reversed list of all the argument vars processed so -;;; far, including supplied-p vars. Default-Vals is a list of the names of the -;;; Default-Vars. +;;; Default-Vars is a reversed list of all the argument vars processed +;;; so far, including supplied-p vars. Default-Vals is a list of the +;;; names of the Default-Vars. ;;; -;;; Entry-Vars is a reversed list of processed argument vars, excluding -;;; supplied-p vars. Entry-Vals is a list things that can be evaluated to get -;;; the values for all the vars from the Entry-Vars. It has the var name for -;;; each required or optional arg, and has T for each supplied-p arg. +;;; Entry-Vars is a reversed list of processed argument vars, +;;; excluding supplied-p vars. Entry-Vals is a list things that can be +;;; evaluated to get the values for all the vars from the Entry-Vars. +;;; It has the var name for each required or optional arg, and has T +;;; for each supplied-p arg. ;;; -;;; Vars is a list of the Lambda-Var structures for arguments that haven't -;;; been processed yet. Supplied-p-p is true if a supplied-p argument has -;;; already been processed; only in this case are the Default-XXX and Entry-XXX -;;; different. +;;; Vars is a list of the Lambda-Var structures for arguments that +;;; haven't been processed yet. Supplied-p-p is true if a supplied-p +;;; argument has already been processed; only in this case are the +;;; Default-XXX and Entry-XXX different. ;;; -;;; The result at each point is a lambda which should be called by the above -;;; level to default the remaining arguments and evaluate the body. We cause -;;; the body to be evaluated by converting it and returning it as the result -;;; when the recursion bottoms out. +;;; The result at each point is a lambda which should be called by the +;;; above level to default the remaining arguments and evaluate the +;;; body. We cause the body to be evaluated by converting it and +;;; returning it as the result when the recursion bottoms out. ;;; -;;; Each level in the recursion also adds its entry point function to the -;;; result Optional-Dispatch. For most arguments, the defaulting function and -;;; the entry point function will be the same, but when supplied-p args are -;;; present they may be different. +;;; Each level in the recursion also adds its entry point function to +;;; the result Optional-Dispatch. For most arguments, the defaulting +;;; function and the entry point function will be the same, but when +;;; supplied-p args are present they may be different. ;;; ;;; When we run into a &REST or &KEY arg, we punt out to ;;; IR1-CONVERT-MORE, which finishes for us in this case. @@ -1733,7 +1702,9 @@ nil nil nil vars supplied-p-p body aux-vars aux-vals cont) (let ((fun (ir1-convert-lambda-body body (reverse default-vars) - aux-vars aux-vals t cont))) + :aux-vars aux-vars + :aux-vals aux-vals + :result cont))) (setf (optional-dispatch-main-entry res) fun) (push (if supplied-p-p (convert-optional-entry fun entry-vars entry-vals ()) @@ -1779,9 +1750,9 @@ aux-vals cont))))))) ;;; This function deals with the case where we have to make an -;;; Optional-Dispatch to represent a lambda. We cons up the result and call -;;; IR1-Convert-Hairy-Args to do the work. When it is done, we figure out the -;;; min-args and max-args. +;;; Optional-Dispatch to represent a lambda. We cons up the result and +;;; call IR1-CONVERT-HAIRY-ARGS to do the work. When it is done, we +;;; figure out the min-args and max-args. (defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals cont) (declare (list body vars aux-vars aux-vals) (type continuation cont)) (let ((res (make-optional-dispatch :arglist vars @@ -1833,8 +1804,10 @@ (ir1-convert-hairy-lambda forms vars keyp allow-other-keys aux-vars aux-vals cont) - (ir1-convert-lambda-body forms vars aux-vars aux-vals - t cont)))) + (ir1-convert-lambda-body forms vars + :aux-vars aux-vars + :aux-vals aux-vals + :result cont)))) (setf (functional-inline-expansion res) form) (setf (functional-arg-documentation res) (cadr form)) (setf (leaf-name res) name) @@ -2007,11 +1980,11 @@ (conts cont) (let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags)))) - (mapc #'(lambda (segment start cont) - (ir1-convert-progn-body start cont (rest segment))) + (mapc (lambda (segment start cont) + (ir1-convert-progn-body start cont (rest segment))) segments (starts) (conts)))))) -;;; Emit an Exit node without any value. +;;; Emit an EXIT node without any value. (def-ir1-translator go ((tag) start cont) #!+sb-doc "Go Tag @@ -2028,113 +2001,36 @@ ;;;; translators for compiler-magic special forms -;;; Do stuff to do an EVAL-WHEN. This is split off from the IR1 -;;; convert method so that it can be shared by the special-case -;;; top-level form processing code. We play with the dynamic -;;; environment and eval stuff, then call Fun with a list of forms to -;;; be processed at load time. +;;; This handles EVAL-WHEN in non-top-level forms. (EVAL-WHENs in +;;; top-level forms are picked off and handled by PROCESS-TOP-LEVEL-FORM, +;;; so they're never seen at this level.) ;;; -;;; Note: the EVAL situation is always ignored: this is conceptually a -;;; compile-only implementation. -;;; -;;; We have to interact with the interpreter to ensure that the forms -;;; get EVAL'ed exactly once. We bind *ALREADY-EVALED-THIS* to true to -;;; inhibit evaluation of any enclosed EVAL-WHENs, either by IR1 -;;; conversion done by EVAL, or by conversion of the body for -;;; load-time processing. If *ALREADY-EVALED-THIS* is true then we *do -;;; not* EVAL since some enclosing EVAL-WHEN already did. -;;; -;;; We know we are EVAL'ing for LOAD since we wouldn't get called -;;; otherwise. If LOAD is a situation we call FUN on body. If we -;;; aren't evaluating for LOAD, then we call FUN on NIL for the result -;;; of the EVAL-WHEN. -(defun do-eval-when-stuff (situations body fun) - - (when (or (not (listp situations)) - (set-difference situations - '(compile load eval - :compile-toplevel :load-toplevel :execute))) - (compiler-error "bad EVAL-WHEN situation list: ~S" situations)) - - (let ((deprecated-names (intersection situations '(compile load eval)))) - (when deprecated-names - (style-warn "using deprecated EVAL-WHEN situation names ~S" - deprecated-names))) - - (let* ((do-eval (and (intersection '(compile :compile-toplevel) situations) - (not sb!eval::*already-evaled-this*))) - (sb!eval::*already-evaled-this* t)) - (when do-eval - - ;; This is the natural way to do it. - #-(and sb-xc-host (or sbcl cmu)) - (eval `(progn ,@body)) - - ;; This is a disgusting hack to work around bug IR1-3 when using - ;; SBCL (or CMU CL, for that matter) as a cross-compilation - ;; host. When we go from the cross-compiler (where we bound - ;; SB!EVAL::*ALREADY-EVALED-THIS*) to the host compiler (which - ;; has a separate SB-EVAL::*ALREADY-EVALED-THIS* variable), EVAL - ;; would go and execute nested EVAL-WHENs even when they're not - ;; toplevel forms. Using EVAL-WHEN instead of bare EVAL causes - ;; the cross-compilation host to bind its own - ;; *ALREADY-EVALED-THIS* variable, so that the problem is - ;; suppressed. - ;; - ;; FIXME: Once bug IR1-3 is fixed, this hack can go away. (Or if - ;; CMU CL doesn't fix the bug, then this hack can be made - ;; conditional on #+CMU.) - #+(and sb-xc-host (or sbcl cmu)) - (let (#+sbcl (sb-eval::*already-evaled-this* t) - #+cmu (common-lisp::*already-evaled-this* t)) - (eval `(eval-when (:compile-toplevel :load-toplevel :execute) - ,@body)))) - - (if (or (intersection '(:load-toplevel load) situations) - (and *converting-for-interpreter* - (intersection '(:execute eval) situations))) - (funcall fun body) - (funcall fun '(nil))))) - -(def-ir1-translator eval-when ((situations &rest body) start cont) +;;; ANSI "3.2.3.1 Processing of Top Level Forms" says that processing +;;; of non-top-level EVAL-WHENs is very simple: +;;; EVAL-WHEN forms cause compile-time evaluation only at top level. +;;; Both :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL situation specifications +;;; 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. +(def-ir1-translator eval-when ((situations &rest forms) start cont) #!+sb-doc "EVAL-WHEN (Situation*) Form* - Evaluate the Forms in the specified Situations, any of COMPILE, LOAD, EVAL. - This is conceptually a compile-only implementation, so EVAL is a no-op." - - ;; It's difficult to handle EVAL-WHENs completely correctly in the - ;; cross-compiler. (Common Lisp is not a cross-compiler-friendly - ;; language..) Since we, the system implementors, control not only - ;; the cross-compiler but also the code that it processes, we can - ;; handle this either by making the cross-compiler smarter about - ;; handling EVAL-WHENs (hard) or by avoiding the use of difficult - ;; EVAL-WHEN constructs (relatively easy). However, since EVAL-WHENs - ;; can be generated by many macro expansions, it's not always easy - ;; to detect problems by skimming the source code, so we'll try to - ;; add some code here to help out. - ;; - ;; Nested EVAL-WHENs are tricky. - #+sb-xc-host - (labels ((contains-toplevel-eval-when-p (body-part) - (and (consp body-part) - (or (eq (first body-part) 'eval-when) - (and (member (first body-part) - '(locally macrolet progn symbol-macrolet)) - (some #'contains-toplevel-eval-when-p - (rest body-part))))))) - (/show "testing for nested EVAL-WHENs" body) - (when (some #'contains-toplevel-eval-when-p body) - (compiler-style-warning "nested EVAL-WHENs in cross-compilation"))) - - (do-eval-when-stuff situations - body - (lambda (forms) - (ir1-convert-progn-body start cont forms)))) - -;;; Like DO-EVAL-WHEN-STUFF, only do a MACROLET. FUN is not passed any -;;; arguments. -(defun do-macrolet-stuff (definitions fun) - (declare (list definitions) (type function fun)) + 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)) + (when e + (ir1-convert-progn-body start cont forms))) + (values)) + +;;; 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 form processing code. +(defun funcall-in-macrolet-lexenv (definitions fun) + (declare (type list definitions) (type function fun)) (let ((whole (gensym "WHOLE")) (environment (gensym "ENVIRONMENT"))) (collect ((new-fenv)) @@ -2155,10 +2051,8 @@ ,(coerce `(lambda (,whole ,environment) ,@local-decs (block ,name ,body)) 'function)))))) - (let ((*lexenv* (make-lexenv :functions (new-fenv)))) (funcall fun)))) - (values)) (def-ir1-translator macrolet ((definitions &rest body) start cont) @@ -2168,9 +2062,45 @@ 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." - (do-macrolet-stuff definitions - #'(lambda () - (ir1-convert-progn-body start cont body)))) + (funcall-in-macrolet-lexenv definitions + (lambda () + (ir1-translate-locally body start cont)))) + +;;; Tweak *LEXENV* to include the MACROBINDINGS from a SYMBOL-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 form processing code. +(defun funcall-in-symbol-macrolet-lexenv (macrobindings fun) + (declare (type list macrobindings) (type function fun)) + (let ((processed-macrobindings + (mapcar (lambda (macrobinding) + (unless (proper-list-of-length-p macrobinding 2) + (compiler-error "malformed symbol/expansion pair: ~S" + macrobinding)) + (destructuring-bind (name expansion) macrobinding + (unless (symbolp name) + (compiler-error + "The symbol macro name ~S is not a symbol." name)) + `(,name . (MACRO . ,expansion)))) + macrobindings))) + (unless (= (length macrobindings) + (length (remove-duplicates macrobindings :key #'first))) + (compiler-style-warning + "duplicate names in SYMBOL-MACROLET ~S" macrobindings)) + (let ((*lexenv* (make-lexenv :variables processed-macrobindings))) + (funcall fun))) + (values)) + +(def-ir1-translator symbol-macrolet ((macrobindings &body body) start cont) + #!+sb-doc + "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form* + Define the Names as symbol macros with the given Expansions. Within the + 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) @@ -2194,9 +2124,6 @@ (compiler-error "Lisp error during evaluation of info args:~%~A" condition)))) -;;; a hashtable that translates from primitive names to translation functions -(defvar *primitive-translators* (make-hash-table :test 'eq)) - ;;; If there is a primitive translator, then we expand the call. ;;; Otherwise, we convert to the %%PRIMITIVE funny function. The first ;;; argument is the template, the second is a list of the results of @@ -2207,60 +2134,54 @@ ;;; a fatal error during IR2 conversion. ;;; ;;; KLUDGE: It's confusing having multiple names floating around for -;;; nearly the same concept: PRIMITIVE, TEMPLATE, VOP. Might it be -;;; possible to reimplement BYTE-BLT (the only use of -;;; *PRIMITIVE-TRANSLATORS*) some other way, then get rid of primitive -;;; translators altogether, so that there would be no distinction -;;; between primitives and vops? Then we could call primitives vops, -;;; rename TEMPLATE to VOP-TEMPLATE, rename BACKEND-TEMPLATE-NAMES to -;;; BACKEND-VOPS, and rename %PRIMITIVE to VOP.. -- WHN 19990906 -;;; FIXME: Look at doing this ^, it doesn't look too hard actually. I -;;; think BYTE-BLT could probably just become an inline function. +;;; nearly the same concept: PRIMITIVE, TEMPLATE, VOP. Now that CMU +;;; CL's *PRIMITIVE-TRANSLATORS* stuff is gone, we could call +;;; primitives VOPs, rename TEMPLATE to VOP-TEMPLATE, rename +;;; 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 ((&whole form name &rest args) start cont) (unless (symbolp name) (compiler-error "The primitive name ~S is not a symbol." name)) - (let* ((translator (gethash name *primitive-translators*))) - (if translator - (ir1-convert start cont (funcall translator (cdr form))) - (let* ((template (or (gethash name *backend-template-names*) - (compiler-error - "The primitive name ~A is not defined." - 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 "Primitive ~A was called with ~R argument~:P, ~ - but wants at least ~R." - name - nargs - min)) - (unless (= nargs min) - (compiler-error "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.")) - - (when (template-more-results-type template) - (compiler-error - "%PRIMITIVE was used with an unknown values template.")) - - (ir1-convert start - cont - `(%%primitive ',template - ',(eval-info-args - (subseq args required min)) - ,@(subseq args 0 required) - ,@(subseq args min))))))) + (let* ((template (or (gethash name *backend-template-names*) + (compiler-error + "The primitive name ~A is not defined." + 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 "Primitive ~A was called with ~R argument~:P, ~ + but wants at least ~R." + name + nargs + min)) + (unless (= nargs min) + (compiler-error "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.")) + + (when (template-more-results-type template) + (compiler-error + "%PRIMITIVE was used with an unknown values template.")) + + (ir1-convert start + cont + `(%%primitive ',template + ',(eval-info-args + (subseq args required min)) + ,@(subseq args 0 required) + ,@(subseq args min))))) ;;;; QUOTE and FUNCTION @@ -2328,32 +2249,6 @@ "optimize away possible call to FDEFINITION at runtime" 'thing) -;;;; symbol macros - -(def-ir1-translator symbol-macrolet ((specs &body body) start cont) - #!+sb-doc - "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form* - Define the Names as symbol macros with the given Expansions. Within the - body, references to a Name will effectively be replaced with the Expansion." - (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) - (collect ((res)) - (dolist (spec specs) - (unless (proper-list-of-length-p spec 2) - (compiler-error "The symbol macro binding ~S is malformed." spec)) - (let ((name (first spec)) - (def (second spec))) - (unless (symbolp name) - (compiler-error "The symbol macro name ~S is not a symbol." name)) - (when (assoc name (res) :test #'eq) - (compiler-style-warning - "The name ~S occurs more than once in SYMBOL-MACROLET." - name)) - (res `(,name . (MACRO . ,def))))) - - (let* ((*lexenv* (make-lexenv :variables (res))) - (*lexenv* (process-decls decls (res) nil cont))) - (ir1-convert-progn-body start cont forms))))) - ;;; This is a frob that DEFSTRUCT expands into to establish the compiler ;;; semantics. The other code in the expansion and %%COMPILER-DEFSTRUCT do ;;; most of the work, we just clear all of the functions out of @@ -2452,31 +2347,36 @@ (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 nil))))) - -;;; This is a lot like a LET* with no bindings. Unlike LET*, LOCALLY -;;; has to preserves top-level-formness, but we don't need to worry -;;; about that here, because special logic in the compiler main loop -;;; grabs top-level LOCALLYs and takes care of them before this -;;; transform ever sees them. -(def-ir1-translator locally ((&body body) - start cont) + (ir1-convert-aux-bindings start cont forms vars values))))) + +;;; logic shared between IR1 translators for LOCALLY, MACROLET, +;;; and SYMBOL-MACROLET +;;; +;;; Note that all these things need to preserve top-level-formness, +;;; but we don't need to worry about that within an IR1 translator, +;;; since top-level-formness is picked off by PROCESS-TOP-LEVEL-FOO +;;; forms before we hit the IR1 transform level. +(defun ir1-translate-locally (body start cont) + (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)))) + +(def-ir1-translator locally ((&body body) start cont) #!+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." - (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 nil)))) + (ir1-translate-locally body start cont)) ;;;; FLET and LABELS ;;; Given a list of local function specifications in the style of -;;; Flet, return lists of the function names and of the lambdas which +;;; FLET, return lists of the function names and of the lambdas which ;;; are their definitions. ;;; -;;; The function names are checked for legality. Context is the name +;;; 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)) @@ -2586,13 +2486,14 @@ (let* ((ctype (values-specifier-type type)) (old-type (or (lexenv-find cont type-restrictions) *wild-type*)) - (intersects (values-types-intersect old-type ctype)) + (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 nil (= inhibit-warnings 3)))) ;FIXME: really OK to suppress? + (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" (type-specifier ctype) @@ -3014,12 +2915,11 @@ (make-null-lexenv)) :variables (copy-list symbol-macros) :functions - (mapcar #'(lambda (x) - `(,(car x) . - (macro . ,(coerce (cdr x) 'function)))) + (mapcar (lambda (x) + `(,(car x) . + (macro . ,(coerce (cdr x) 'function)))) macros) - :policy (lexenv-policy *lexenv*) - :interface-policy (lexenv-interface-policy *lexenv*)))) + :policy (lexenv-policy *lexenv*)))) (ir1-convert-lambda `(lambda ,@body) name)))) ;;; Return a lambda that has been "closed" with respect to ENV, @@ -3115,9 +3015,6 @@ ;; 3.2.2.3 of the spec) but at least as of sbcl-0.6.11, we don't ;; keep track of whether the mismatched data came from the same ;; compilation unit, so we can't do that. -- WHN 2001-02-11 - ;; - ;; FIXME: Actually, I think we could issue a full WARNING if the - ;; new definition contradicts a DECLAIM FTYPE. :error-function #'compiler-style-warning :warning-function (cond (info #'compiler-style-warning) (for-real #'compiler-note)