X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=307d76224d37b334e6ab3e26e27a0f5956793abe;hb=dfa55a883f94470267b626dae77ce7e7dfac3df6;hp=fdb8a02940bb8231730dffdcb3c8b4fe3505a308;hpb=985c2d805428e1bbc479524fc955da5028d3e66e;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index fdb8a02..307d762 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -48,13 +48,6 @@ (defvar *converting-for-interpreter* nil) ;;; FIXME: Rename to *IR1-FOR-INTERPRETER-NOT-COMPILER-P*. -;;; *COMPILE-TIME-DEFINE-MACROS* is true when we want DEFMACRO -;;; definitions to be installed in the compilation environment as -;;; interpreted functions. We set this to false when compiling some -;;; parts of the system. -(defvar *compile-time-define-macros* t) -;;; FIXME: I think this can go away with the new system. - ;;; 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 @@ -79,7 +72,13 @@ (setf (info :function :where-from name) :assumed)) (let ((where (info :function :where-from name))) - (when (eq where :assumed) + (when (and (eq where :assumed) + ;; In the ordinary target Lisp, it's silly to report + ;; undefinedness when the function is defined in the + ;; running Lisp. But at cross-compile time, the current + ;; definedness of a function is irrelevant to the + ;; definedness at runtime, which is what matters. + #-sb-xc-host (not (fboundp name))) (note-undefined-reference name :function)) (make-global-var :kind :global-function :name name @@ -100,7 +99,8 @@ (slot (find accessor (dd-slots info) :key #'sb!kernel:dsd-accessor)) (type (dd-name info)) (slot-type (dsd-type slot))) - (assert slot () "Can't find slot ~S." type) + (unless slot + (error "can't find slot ~S" type)) (make-slot-accessor :name name :type (specifier-type @@ -162,7 +162,7 @@ (let ((var (lexenv-find name functions :test #'equal))) (cond (var (unless (leaf-p var) - (assert (and (consp var) (eq (car var) 'macro))) + (aver (and (consp var) (eq (car var) 'macro))) (compiler-error "found macro name ~S ~A" name context)) var) (t @@ -204,7 +204,10 @@ ;;; processed with MAKE-LOAD-FORM. We have to be careful, because ;;; CONSTANT might be circular. We also check that the constant (and ;;; any subparts) are dumpable at all. -(defconstant list-to-hash-table-threshold 32) +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; The EVAL-WHEN is necessary for #.(1+ LIST-TO-HASH-TABLE-THRESHOLD) + ;; below. -- AL 20010227 + (defconstant list-to-hash-table-threshold 32)) (defun maybe-emit-make-load-forms (constant) (let ((things-processed nil) (count 0)) @@ -280,7 +283,7 @@ #!-sb-fluid (declaim (inline prev-link)) (defun prev-link (node cont) (declare (type node node) (type continuation cont)) - (assert (not (continuation-next cont))) + (aver (not (continuation-next cont))) (setf (continuation-next cont) node) (setf (node-prev node) cont)) @@ -311,15 +314,15 @@ (declare (type node node) (type continuation cont) (inline member)) (let ((block (continuation-block cont)) (node-block (continuation-block (node-prev node)))) - (assert (eq (continuation-kind cont) :block-start)) - (assert (not (block-last node-block)) () "~S has already ended." - node-block) + (aver (eq (continuation-kind cont) :block-start)) + (when (block-last node-block) + (error "~S has already ended." node-block)) (setf (block-last node-block) node) - (assert (null (block-succ node-block)) () "~S already has successors." - node-block) + (when (block-succ node-block) + (error "~S already has successors." node-block)) (setf (block-succ node-block) (list block)) - (assert (not (member node-block (block-pred block) :test #'eq)) () - "~S is already a predecessor of ~S." node-block block) + (when (memq node-block (block-pred block)) + (error "~S is already a predecessor of ~S." node-block block)) (push node-block (block-pred block)) (add-continuation-use node cont) (unless (eq (continuation-asserted-type cont) *wild-type*) @@ -469,8 +472,8 @@ (global-var (ir1-convert-srctran start cont lexical-def form)) (t - (assert (and (consp lexical-def) - (eq (car lexical-def) 'macro))) + (aver (and (consp lexical-def) + (eq (car lexical-def) 'macro))) (ir1-convert start cont (careful-expand-macro (cdr lexical-def) form)))))) @@ -545,7 +548,7 @@ (compiler-style-warning "reading an ignored variable: ~S" name)) (reference-leaf start cont var)) (cons - (assert (eq (car var) 'MACRO)) + (aver (eq (car var) 'MACRO)) (ir1-convert start cont (cdr var))) (heap-alien-info (ir1-convert start cont `(%heap-alien ',var))))) @@ -807,7 +810,7 @@ ;;; If a lambda-var being bound, we intersect the type with the vars ;;; type, otherwise we add a type-restriction on the var. If a symbol ;;; macro, we just wrap a THE around the expansion. -(defun process-type-declaration (decl res vars) +(defun process-type-decl (decl res vars) (declare (list decl vars) (type lexenv res)) (let ((type (specifier-type (first decl)))) (collect ((restr nil cons) @@ -824,9 +827,9 @@ (int (if (or (function-type-p type) (function-type-p old-type)) type - (type-intersection old-type type)))) + (type-approx-intersection2 old-type type)))) (cond ((eq int *empty-type*) - (unless (policy nil (= brevity 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) @@ -836,7 +839,7 @@ (restr (cons var int)))))) (cons ;; FIXME: non-ANSI weirdness - (assert (eq (car var) 'MACRO)) + (aver (eq (car var) 'MACRO)) (new-vars `(,var-name . (MACRO . (the ,(first decl) ,(cdr var)))))) (heap-alien-info @@ -850,12 +853,12 @@ :variables (new-vars)) res)))) -;;; Somewhat similar to Process-Type-Declaration, but handles +;;; This is somewhat similar to PROCESS-TYPE-DECL, but handles ;;; declarations for function variables. In addition to allowing ;;; declarations for functions being bound, we must also deal with ;;; declarations that constrain the type of lexically apparent ;;; functions. -(defun process-ftype-declaration (spec res names fvars) +(defun process-ftype-decl (spec res names fvars) (declare (list spec names fvars) (type lexenv res)) (let ((type (specifier-type spec))) (collect ((res nil cons)) @@ -878,14 +881,14 @@ ;;; Process a special declaration, returning a new LEXENV. A non-bound ;;; special declaration is instantiated by throwing a special variable ;;; into the variables. -(defun process-special-declaration (spec res vars) +(defun process-special-decl (spec res vars) (declare (list spec vars) (type lexenv res)) (collect ((new-venv nil cons)) (dolist (name (cdr spec)) (let ((var (find-in-bindings vars name))) (etypecase var (cons - (assert (eq (car var) 'MACRO)) + (aver (eq (car var) 'MACRO)) (compiler-error "~S is a symbol-macro and thus can't be declared special." name)) @@ -922,8 +925,8 @@ ;;; Parse an inline/notinline declaration. If it's a local function we're ;;; defining, set its INLINEP. If a global function, add a new FENV entry. -(defun process-inline-declaration (spec res fvars) - (let ((sense (cdr (assoc (first spec) inlinep-translations :test #'eq))) +(defun process-inline-decl (spec res fvars) + (let ((sense (cdr (assoc (first spec) *inlinep-translations* :test #'eq))) (new-fenv ())) (dolist (name (rest spec)) (let ((fvar (find name fvars :key #'leaf-name :test #'equal))) @@ -934,7 +937,7 @@ name "in an inline or notinline declaration"))) (etypecase found (functional - (when (policy nil (>= speed brevity)) + (when (policy *lexenv* (>= speed inhibit-warnings)) (compiler-note "ignoring ~A declaration not at ~ definition of local function:~% ~S" sense name))) @@ -959,7 +962,7 @@ ;;; Process an ignore/ignorable declaration, checking for various losing ;;; conditions. -(defun process-ignore-declaration (spec vars fvars) +(defun process-ignore-decl (spec vars fvars) (declare (list spec vars fvars)) (dolist (name (rest spec)) (let ((var (find-in-bindings-or-fbindings name vars fvars))) @@ -992,87 +995,59 @@ #!+sb-doc "If true, processing of the VALUES declaration is inhibited.") -;;; Process a single declaration spec, agumenting the specified LEXENV -;;; Res and returning it as a result. Vars and Fvars are as described in +;;; Process a single declaration spec, augmenting the specified LEXENV +;;; RES and returning it as a result. VARS and FVARS are as described in ;;; PROCESS-DECLS. -(defun process-1-declaration (spec res vars fvars cont) - (declare (list spec vars fvars) (type lexenv res) (type continuation cont)) - (case (first spec) - (special (process-special-declaration spec res vars)) - (ftype - (unless (cdr spec) - (compiler-error "No type specified in FTYPE declaration: ~S." spec)) - (process-ftype-declaration (second spec) res (cddr spec) fvars)) - (function - ;; Handle old style FUNCTION declaration, which is an abbreviation for - ;; FTYPE. Args are name, arglist, result type. - (cond ((and (proper-list-of-length-p spec 3 4) - (listp (third spec))) - (process-ftype-declaration `(function ,@(cddr spec)) res - (list (second spec)) - fvars)) - (t - (process-type-declaration spec res vars)))) - ((inline notinline maybe-inline) - (process-inline-declaration spec res fvars)) - ((ignore ignorable) - (process-ignore-declaration spec vars fvars) - res) - (optimize - (make-lexenv - :default res - :cookie (process-optimize-declaration spec (lexenv-cookie res)))) - (optimize-interface - (make-lexenv - :default res - :interface-cookie (process-optimize-declaration - spec - (lexenv-interface-cookie res)))) - (type - (process-type-declaration (cdr spec) res vars)) - (sb!pcl::class - (process-type-declaration (list (third spec) (second spec)) res vars)) - (values - (if *suppress-values-declaration* - res - (let ((types (cdr spec))) - (do-the-stuff (if (eql (length types) 1) - (car types) - `(values ,@types)) - cont res 'values)))) - (dynamic-extent - (when (policy nil (> speed brevity)) - (compiler-note - "The DYNAMIC-EXTENT declaration is not implemented (ignored).")) - res) - (t - (let ((what (first spec))) - (cond ((member what *standard-type-names*) - (process-type-declaration spec res vars)) - ((and (not (and (symbolp what) - (string= (symbol-name what) "CLASS"))) ; pcl hack - (or (info :type :kind what) - (and (consp what) (info :type :translator (car what))))) -;;; MNA - abbreviated declaration bug -;; (unless (policy nil (= brevity 3)) - ;; FIXME: Is it ANSI to warn about this? I think not. -;; (compiler-note "abbreviated type declaration: ~S." spec)) - (process-type-declaration spec res vars)) - ((info :declaration :recognized what) - res) - (t - (compiler-warning "unrecognized declaration ~S" spec) - res)))))) - -;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR and -;;; Functional structures which are being bound. In addition to filling in -;;; slots in the leaf structures, we return a new LEXENV which reflects -;;; pervasive special and function type declarations, (NOT)INLINE declarations -;;; and OPTIMIZE declarations. CONT is the continuation affected by VALUES -;;; declarations. +(defun process-1-decl (raw-spec res vars fvars cont) + (declare (type list raw-spec vars fvars)) + (declare (type lexenv res)) + (declare (type continuation cont)) + (let ((spec (canonized-decl-spec raw-spec))) + (case (first spec) + (special (process-special-decl spec res vars)) + (ftype + (unless (cdr spec) + (compiler-error "No type specified in FTYPE declaration: ~S" spec)) + (process-ftype-decl (second spec) res (cddr spec) fvars)) + ((inline notinline maybe-inline) + (process-inline-decl spec res fvars)) + ((ignore ignorable) + (process-ignore-decl spec vars fvars) + res) + (optimize + (make-lexenv + :default res + :policy (process-optimize-decl spec (lexenv-policy res)))) + (type + (process-type-decl (cdr spec) res vars)) + (values + (if *suppress-values-declaration* + res + (let ((types (cdr spec))) + (do-the-stuff (if (eql (length types) 1) + (car types) + `(values ,@types)) + cont res 'values)))) + (dynamic-extent + (when (policy *lexenv* (> speed inhibit-warnings)) + (compiler-note + "compiler limitation:~ + ~% There's no special support for DYNAMIC-EXTENT (so it's ignored).")) + res) + (t + (unless (info :declaration :recognized (first spec)) + (compiler-warning "unrecognized declaration ~S" raw-spec)) + res)))) + +;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR +;;; and FUNCTIONAL structures which are being bound. In addition to +;;; filling in slots in the leaf structures, we return a new LEXENV +;;; which reflects pervasive special and function type declarations, +;;; (NOT)INLINE declarations and OPTIMIZE declarations. CONT is the +;;; continuation affected by VALUES declarations. ;;; -;;; This is also called in main.lisp when PROCESS-FORM handles a use of -;;; LOCALLY. +;;; This is also called in main.lisp when PROCESS-FORM handles a use +;;; of LOCALLY. (defun process-decls (decls vars fvars cont &optional (env *lexenv*)) (declare (list decls vars fvars) (type continuation cont)) (dolist (decl decls) @@ -1081,10 +1056,10 @@ (compiler-error "malformed declaration specifier ~S in ~S" spec decl)) - (setq env (process-1-declaration spec env vars fvars cont)))) + (setq env (process-1-decl spec env vars fvars cont)))) env) -;;; Return the Specvar for Name to use when we see a local SPECIAL +;;; Return the SPECVAR for NAME to use when we see a local SPECIAL ;;; declaration. If there is a global variable of that name, then ;;; check that it isn't a constant and return it. Otherwise, create an ;;; anonymous GLOBAL-VAR. @@ -1139,38 +1114,38 @@ (note-lexical-binding name) (make-lambda-var :name name))))) -;;; Make the keyword for a keyword arg, checking that the keyword -;;; isn't already used by one of the Vars. We also check that the -;;; keyword isn't the magical :allow-other-keys. +;;; Make the default keyword for a &KEY arg, checking that the keyword +;;; isn't already used by one of the VARS. We also check that the +;;; keyword isn't the magical :ALLOW-OTHER-KEYS. (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 keyword arg can be called :ALLOW-OTHER-KEYS.")) + (compiler-error "No &KEY arg can be called :ALLOW-OTHER-KEYS.")) (dolist (var vars) (let ((info (lambda-var-arg-info var))) (when (and info (eq (arg-info-kind info) :keyword) - (eq (arg-info-keyword info) key)) + (eq (arg-info-key info) key)) (compiler-error "The keyword ~S appears more than once in the lambda-list." key)))) key)) -;;; Parse a lambda-list into a list of Var structures, stripping off +;;; Parse a lambda-list into a list of VAR structures, stripping off ;;; any aux bindings. Each arg name is checked for legality, and ;;; duplicate names are checked for. If an arg is globally special, -;;; the var is marked as :special instead of :lexical. Keyword, -;;; optional and rest args are annotated with an arg-info structure +;;; the var is marked as :SPECIAL instead of :LEXICAL. &KEY, +;;; &OPTIONAL and &REST args are annotated with an ARG-INFO structure ;;; which contains the extra information. If we hit something losing, -;;; we bug out with Compiler-Error. These values are returned: -;;; 1. A list of the var structures for each top-level argument. -;;; 2. A flag indicating whether &key was specified. -;;; 3. A flag indicating whether other keyword args are allowed. -;;; 4. A list of the &aux variables. -;;; 5. A list of the &aux values. +;;; we bug out with COMPILER-ERROR. These values are returned: +;;; 1. a list of the var structures for each top-level argument; +;;; 2. a flag indicating whether &KEY was specified; +;;; 3. a flag indicating whether other &KEY args are allowed; +;;; 4. a list of the &AUX variables; and +;;; 5. a list of the &AUX values. (declaim (ftype (function (list) (values list boolean boolean list list)) find-lambda-vars)) (defun find-lambda-vars (list) @@ -1181,9 +1156,9 @@ (names-so-far) (aux-vars) (aux-vals)) - ;; Parse-Default deals with defaults and supplied-p args for optionals - ;; and keywords args. - (flet ((parse-default (spec info) + (flet (;; PARSE-DEFAULT deals with defaults and supplied-p args + ;; for optionals and keywords args. + (parse-default (spec info) (when (consp (cdr spec)) (setf (arg-info-default info) (second spec)) (when (consp (cddr spec)) @@ -1240,9 +1215,9 @@ (let ((var (varify-lambda-arg spec (names-so-far)))) (setf (lambda-var-arg-info var) (make-arg-info :kind :keyword - :keyword (make-keyword-for-arg spec - (vars) - t))) + :key (make-keyword-for-arg spec + (vars) + t))) (vars var) (names-so-far spec))) ((atom (first spec)) @@ -1250,7 +1225,7 @@ (var (varify-lambda-arg name (names-so-far))) (info (make-arg-info :kind :keyword - :keyword (make-keyword-for-arg name (vars) t)))) + :key (make-keyword-for-arg name (vars) t)))) (setf (lambda-var-arg-info var) info) (vars var) (names-so-far name) @@ -1258,14 +1233,14 @@ (t (let ((head (first spec))) (unless (proper-list-of-length-p head 2) - (error "malformed keyword arg specifier: ~S" spec)) + (error "malformed &KEY argument specifier: ~S" spec)) (let* ((name (second head)) (var (varify-lambda-arg name (names-so-far))) (info (make-arg-info :kind :keyword - :keyword (make-keyword-for-arg (first head) - (vars) - nil)))) + :key (make-keyword-for-arg (first head) + (vars) + nil)))) (setf (lambda-var-arg-info var) info) (vars var) (names-so-far name) @@ -1289,48 +1264,41 @@ (values (vars) keyp allowp (aux-vars) (aux-vals)))))) -;;; Similar to IR1-Convert-Progn-Body except that we 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 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) +;;; This is similar to IR1-CONVERT-PROGN-BODY except that we +;;; 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. +(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 - :cookie (make-interface-cookie *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)) -;;; Similar to IR1-Convert-Progn-Body except that code to bind the Specvar -;;; for each Svar to the value of the variable is wrapped around the body. If -;;; there are no special bindings, we just convert the body, otherwise we do -;;; one special binding and recurse on the rest. +;;; This is similar to IR1-CONVERT-PROGN-BODY except that code to bind +;;; the SPECVAR for each SVAR to the value of the variable is wrapped +;;; around the body. If there are no special bindings, we just convert +;;; the body, otherwise we do one special binding and recurse on the +;;; rest. ;;; -;;; We make a cleanup and introduce it into the lexical environment. If -;;; there are multiple special bindings, the cleanup for the blocks 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) +;;; We make a cleanup and introduce it into the lexical environment. +;;; If there are multiple special bindings, the cleanup for the blocks +;;; 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 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)) @@ -1343,30 +1311,27 @@ (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 -;;; bindings are specified by the list of var structures Vars. We deal -;;; with adding the names to the Lexenv-Variables for the conversion. -;;; The result is added to the New-Functions in the -;;; *Current-Component* and linked to the component head and tail. +;;; bindings are specified by the list of VAR structures VARS. We deal +;;; with adding the names to the LEXENV-VARIABLES for the conversion. +;;; The result is added to the NEW-FUNCTIONS in the +;;; *CURRENT-COMPONENT* and linked to the component head and tail. ;;; -;;; We detect special bindings here, replacing the original Var in the +;;; We detect special bindings here, replacing the original VAR in the ;;; lambda list with a temporary variable. We then pass a list of the -;;; special vars to IR1-Convert-Special-Bindings, which actually emits +;;; special vars to IR1-CONVERT-SPECIAL-BINDINGS, which actually emits ;;; the special binding code. ;;; -;;; We ignore any Arg-Info in the Vars, trusting that someone else is +;;; We ignore any ARG-INFO in the VARS, trusting that someone else is ;;; dealing with &nonsense. ;;; -;;; 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) +;;; 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. +(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)) @@ -1398,7 +1363,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 @@ -1418,16 +1383,14 @@ lambda)) ;;; Create the actual entry-point function for an optional entry -;;; point. The lambda binds copies of each of the Vars, then calls Fun -;;; with the argument Vals and the Defaults. Presumably the Vals refer -;;; to the Vars by name. The Vals are passed in in reverse order. +;;; point. The lambda binds copies of each of the VARS, then calls FUN +;;; with the argument VALS and the DEFAULTS. Presumably the VALS refer +;;; to the VARS by name. The VALS are passed in in reverse order. ;;; ;;; If any of the copies of the vars are referenced more than once, -;;; then we mark the corresponding var as Ever-Used to inhibit +;;; 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)) @@ -1440,20 +1403,20 @@ :where-from (leaf-where-from var) :specvar (lambda-var-specvar var))) fvars)) - (*lexenv* (make-lexenv :cookie (make-interface-cookie *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)) ;;; This function deals with supplied-p vars in optional arguments. If ;;; the there is no supplied-p arg, then we just call -;;; IR1-Convert-Hairy-Args on the remaining arguments, and generate a +;;; IR1-CONVERT-HAIRY-ARGS on the remaining arguments, and generate a ;;; optional entry that calls the result. If there is a supplied-p ;;; var, then we add it into the default vars and throw a T into the ;;; entry values. The resulting entry point function is returned. @@ -1490,32 +1453,30 @@ (list (arg-info-default info) nil) (list (arg-info-default info)))))) -;;; Create the More-Entry function for the Optional-Dispatch Res. -;;; Entry-Vars and Entry-Vals describe the fixed arguments. Rest is the var -;;; for any Rest arg. Keys is a list of the keyword arg vars. +;;; Create the MORE-ENTRY function for the OPTIONAL-DISPATCH RES. +;;; ENTRY-VARS and ENTRY-VALS describe the fixed arguments. REST is +;;; the var for any &REST arg. KEYS is a list of the &KEY arg vars. ;;; -;;; The most interesting thing that we do is parse keywords. We create a -;;; bunch of temporary variables to hold the result of the parse, and then loop -;;; over the supplied arguments, setting the appropriate temps for the supplied -;;; keyword. Note that it is significant that we iterate over the keywords in -;;; reverse order --- this implements the CL requirement that (when a keyword -;;; appears more than once) the first value is used. +;;; The most interesting thing that we do is parse keywords. We create +;;; a bunch of temporary variables to hold the result of the parse, +;;; and then loop over the supplied arguments, setting the appropriate +;;; temps for the supplied keyword. Note that it is significant that +;;; we iterate over the keywords in reverse order --- this implements +;;; the CL requirement that (when a keyword appears more than once) +;;; the first value is used. ;;; ;;; If there is no supplied-p var, then we initialize the temp to the -;;; default and just pass the temp into the main entry. Since non-constant -;;; keyword args are forcibly given a supplied-p var, we know that the default -;;; is constant, and thus safe to evaluate out of order. +;;; default and just pass the temp into the main entry. Since +;;; non-constant &KEY args are forcibly given a supplied-p var, we +;;; know that the default is constant, and thus safe to evaluate out +;;; of order. ;;; -;;; If there is a supplied-p var, then we create temps for both the value -;;; and the supplied-p, and pass them into the main entry, letting it worry -;;; about defaulting. +;;; If there is a supplied-p var, then we create temps for both the +;;; value and the supplied-p, and pass them into the main entry, +;;; letting it worry about defaulting. ;;; -;;; 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. +;;; We deal with :ALLOW-OTHER-KEYS by delaying unknown keyword errors +;;; until we have scanned all the keywords. (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) @@ -1532,8 +1493,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 :cookie (make-interface-cookie *lexenv*)))) + :type (specifier-type 'index)))) (arg-vars context-temp count-temp) @@ -1550,7 +1510,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))) @@ -1559,7 +1519,7 @@ (dolist (key keys) (let* ((info (lambda-var-arg-info key)) (default (arg-info-default info)) - (keyword (arg-info-keyword info)) + (keyword (arg-info-key info)) (supplied-p (arg-info-supplied-p info)) (n-value (gensym "N-VALUE-"))) (temps `(,n-value ,default)) @@ -1567,13 +1527,11 @@ (let ((n-supplied (gensym "N-SUPPLIED-"))) (temps n-supplied) (arg-vals n-value n-supplied) - ;; MNA: non-self-eval-keyword patch (tests `((eq ,n-key ',keyword) (setq ,n-supplied t) (setq ,n-value ,n-value-temp))))) (t (arg-vals n-value) - ;; MNA: non-self-eval-keyword patch (tests `((eq ,n-key ',keyword) (setq ,n-value ,n-value-temp))))))) @@ -1586,7 +1544,7 @@ (body `(when (oddp ,n-count) - (%odd-keyword-arguments-error))) + (%odd-key-arguments-error))) (body `(locally @@ -1601,7 +1559,7 @@ (unless allowp (body `(when (and ,n-losep (not ,n-allowp)) - (%unknown-keyword-argument-error ,n-losep))))))) + (%unknown-key-argument-error ,n-losep))))))) (let ((ep (ir1-convert-lambda-body `((let ,(temps) @@ -1613,17 +1571,17 @@ (values)) -;;; Called by IR1-Convert-Hairy-Args when we run into a rest or -;;; keyword 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 the -;;; keyword argument vars. +;;; 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 +;;; the &KEY argument vars. ;;; -;;; When there are keyword arguments, we introduce temporary gensym +;;; When there are &KEY arguments, we introduce temporary gensym ;;; variables to hold the values while keyword defaulting is in ;;; progress to get the required sequential binding semantics. ;;; -;;; This gets interesting mainly when there are keyword arguments with +;;; This gets interesting mainly when there are &KEY arguments with ;;; supplied-p vars or non-constant defaults. In either case, pass in ;;; a supplied-p var. If the default is non-constant, we introduce an ;;; IF in the main entry that tests the supplied-p var and decides @@ -1687,11 +1645,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) @@ -1708,32 +1666,33 @@ ;;; 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 keyword arg, we punt out to -;;; IR1-Convert-More, which finishes for us in this case. +;;; When we run into a &REST or &KEY arg, we punt out to +;;; IR1-CONVERT-MORE, which finishes for us in this case. (defun ir1-convert-hairy-args (res default-vars default-vals entry-vars entry-vals vars supplied-p-p body aux-vars @@ -1750,7 +1709,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 ()) @@ -1796,9 +1757,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 @@ -1850,8 +1811,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) @@ -1928,11 +1891,9 @@ (prev-link entry start) (use-continuation entry dummy) - ;; MNA - Re: two obscure bugs in CMU CL (let* ((env-entry (list entry cont)) - (*lexenv* - (make-lexenv :blocks (list (cons name env-entry)) - :cleanup cleanup))) + (*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)))) @@ -1960,7 +1921,7 @@ (prev-link exit value-cont) (use-continuation exit (second found)))) -;;; Return a list of the segments of a tagbody. Each segment looks +;;; Return a list of the segments of a TAGBODY. Each segment looks ;;; like (
* (go )). That is, we break up the ;;; tagbody into segments of non-tag statements, and explicitly ;;; represent the drop-through with a GO. The first segment has a @@ -1972,7 +1933,7 @@ (collect ((segments)) (let ((current (cons nil body))) (loop - (let ((tag-pos (position-if-not #'listp current :start 1))) + (let ((tag-pos (position-if (complement #'listp) current :start 1))) (unless tag-pos (segments `(,@current nil)) (return)) @@ -2016,15 +1977,13 @@ (conts)) (starts dummy) (dolist (segment (rest segments)) - ;; MNA - Re: two obscure bugs (let* ((tag-cont (make-continuation)) (tag (list (car segment) entry tag-cont))) (conts tag-cont) (starts tag-cont) (continuation-starts-block tag-cont) (tags tag) - (push (cdr tag) (continuation-lexenv-uses tag-cont)) - )) + (push (cdr tag) (continuation-lexenv-uses tag-cont)))) (conts cont) (let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags)))) @@ -2063,7 +2022,7 @@ ;;; 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. +;;; 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 @@ -2086,7 +2045,31 @@ (not sb!eval::*already-evaled-this*))) (sb!eval::*already-evaled-this* t)) (when do-eval - (eval `(progn ,@body))) + + ;; 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))) @@ -2098,11 +2081,37 @@ "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." - (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 + ;; 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)) @@ -2423,7 +2432,7 @@ (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))))) + (ir1-convert-aux-bindings start cont forms vars values))))) ;;; 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 @@ -2439,8 +2448,7 @@ 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))) - ;;; MNA: locally patch - #'ir1-convert-progn-body gets called anyway! - (ir1-convert-progn-body start cont forms)))) + (ir1-convert-aux-bindings start cont forms nil nil)))) ;;;; FLET and LABELS @@ -2521,9 +2529,9 @@ ;;;; THE -;;; 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 +;;; 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. ;;; @@ -2542,8 +2550,8 @@ ;;; 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 +;;; 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 @@ -2558,13 +2566,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 (= brevity 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) @@ -2573,26 +2582,26 @@ (make-lexenv :type-restrictions `((,cont . ,new)) :default lexenv))) +;;; Assert that FORM evaluates to the specified type (which may be a +;;; VALUES type). +;;; ;;; FIXME: In a version of CMU CL that I used at Cadabra ca. 20000101, ;;; this didn't seem to expand into an assertion, at least for ALIEN ;;; values. Check that SBCL doesn't have this problem. (def-ir1-translator the ((type value) start cont) - #!+sb-doc - "THE Type Form - Assert that Form evaluates to the specified type (which may be a VALUES - type.)" (let ((*lexenv* (do-the-stuff type cont *lexenv* 'the))) (ir1-convert start cont value))) +;;; 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 - "Truly-The Type Value - 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." (declare (inline member)) (let ((type (values-specifier-type type)) (old (find-uses cont))) @@ -2607,11 +2616,6 @@ ;;; 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) - #!+sb-doc - "SETQ {Var Value}* - Set the variables to the values. If more than one pair is supplied, the - assignments are done sequentially. If Var names a symbol macro, SETF the - expansion." (let ((len (length things))) (when (oddp len) (compiler-error "odd number of args to SETQ: ~S" source)) @@ -2634,7 +2638,7 @@ name)) (set-variable start cont leaf (second things))) (cons - (assert (eq (car leaf) 'MACRO)) + (aver (eq (car leaf) 'MACRO)) (ir1-convert start cont `(setf ,(cdr leaf) ,(second things)))) (heap-alien-info (ir1-convert start cont @@ -2645,8 +2649,8 @@ (ir1-convert-progn-body start cont (sets))) (sets `(setq ,(first thing) ,(second thing)))))))) -;;; Kind of like Reference-Leaf, but we generate a Set node. This -;;; should only need to be called in Setq. +;;; 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) (declare (type continuation start cont) (type basic-var var)) (let ((dest (make-continuation))) @@ -2673,11 +2677,11 @@ `(multiple-value-call #'%throw ,tag ,result))) ;;; This is a special special form used to instantiate a cleanup as -;;; the current cleanup within the body. Kind is a the kind of cleanup -;;; to make, and Mess-Up is a form that does the mess-up action. We -;;; make the MESS-UP be the USE of the Mess-Up form's continuation, +;;; the current cleanup within the body. KIND is a the kind of cleanup +;;; to make, and MESS-UP is a form that does the mess-up action. We +;;; make the MESS-UP be the USE of the MESS-UP form's continuation, ;;; and introduce the cleanup into the lexical environment. We -;;; back-patch the Entry-Cleanup for the current cleanup to be the new +;;; back-patch the ENTRY-CLEANUP for the current cleanup to be the new ;;; cleanup, since this inner cleanup is the interesting one. (def-ir1-translator %within-cleanup ((kind mess-up &body body) start cont) (let ((dummy (make-continuation)) @@ -2694,13 +2698,13 @@ ;;; This is a special special form that makes an "escape function" ;;; which returns unknown values from named block. We convert the -;;; function, set its kind to :Escape, and then reference it. The +;;; function, set its kind to :ESCAPE, and then reference it. The ;;; :Escape kind indicates that this function's purpose is to ;;; represent a non-local control transfer, and that it might not ;;; actually have to be compiled. ;;; ;;; Note that environment analysis replaces references to escape -;;; functions with references to the corresponding NLX-Info structure. +;;; functions with references to the corresponding NLX-INFO structure. (def-ir1-translator %escape-function ((tag) start cont) (let ((fun (ir1-convert-lambda `(lambda () @@ -2709,17 +2713,17 @@ (reference-leaf start cont fun))) ;;; Yet another special special form. This one looks up a local -;;; function and smashes it to a :Cleanup function, as well as +;;; 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))) - (assert (lambda-p fun)) + (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. +;;; cleanup using %WITHIN-CLEANUP. (def-ir1-translator catch ((tag &body body) start cont) #!+sb-doc "Catch Tag Form* @@ -2739,8 +2743,8 @@ ;;; UNWIND-PROTECT is similar to CATCH, but more hairy. 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 +;;; 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 @@ -2775,12 +2779,12 @@ ;;;; multiple-value stuff ;;; If there are arguments, MULTIPLE-VALUE-CALL turns into an -;;; MV-Combination. +;;; MV-COMBINATION. ;;; ;;; If there are no arguments, then we convert to a normal -;;; combination, ensuring that a MV-Combination always has at least +;;; 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. +;;; 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* @@ -2808,16 +2812,16 @@ (use-continuation node cont) (setf (basic-combination-args node) (arg-conts)))))) -;;; Multiple-Value-Prog1 is represented implicitly in IR1 by having a +;;; MULTIPLE-VALUE-PROG1 is represented implicitly in IR1 by having a ;;; the result code use result continuation (CONT), but transfer ;;; control to the evaluation of the body. In other words, the result -;;; continuation isn't Immediately-Used-P by the nodes that compute +;;; continuation isn't IMMEDIATELY-USED-P by the nodes that compute ;;; the result. ;;; ;;; In order to get the control flow right, we convert the result with ;;; a dummy result continuation, then convert all the uses of the -;;; dummy to be uses of CONT. If a use is an Exit, then we also -;;; substitute CONT for the dummy in the corresponding Entry node so +;;; dummy to be uses of CONT. If a use is an EXIT, then we also +;;; substitute CONT for the dummy in the corresponding ENTRY node so ;;; that they are consistent. Note that this doesn't amount to ;;; changing the exit target, since the control destination of an exit ;;; is determined by the block successor; we are just indicating the @@ -2830,7 +2834,7 @@ ;;; Note that we both exploit and maintain the invariant that the CONT ;;; to an IR1 convert method either has no block or starts the block ;;; that control should transfer to after completion for the form. -;;; Nested MV-Prog1's work because during conversion of the result +;;; Nested MV-PROG1's work because during conversion of the result ;;; form, we use dummy continuation whose block is the true control ;;; destination. (def-ir1-translator multiple-value-prog1 ((result &rest forms) start cont) @@ -2853,19 +2857,24 @@ (dolist (pred (block-pred end-block)) (unlink-blocks pred end-block) (link-blocks pred cont-block)) - (assert (not (continuation-dest dummy-result))) + (aver (not (continuation-dest dummy-result))) (delete-continuation dummy-result) (remove-from-dfo end-block)))) ;;;; interface to defining macros -;;;; DEFMACRO, DEFUN and DEFCONSTANT 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. +;;;; 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. +;;; 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. (defun revert-source-path (name) @@ -2891,8 +2900,8 @@ ;; 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 - (assert (eq 'function (first qdef))) - (assert (proper-list-of-length-p qdef 2)) + (aver (eq 'function (first qdef))) + (aver (proper-list-of-length-p qdef 2)) (second qdef)))) (unless (symbolp name) @@ -2912,12 +2921,9 @@ (compiler-error "The special form ~S can't be redefined as a macro." name))) - (setf (info :function :kind name) :macro) - (setf (info :function :where-from name) :defined) - - (when *compile-time-define-macros* - (setf (info :function :macro-function name) - (coerce def 'function))) + (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 name))) @@ -2928,22 +2934,37 @@ (ir1-convert start cont `(%%defmacro ',name ,fun ,doc))) (when sb!xc:*compile-print* - ;; MNA compiler message patch + ;; 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))) ; Don't want to make a function just yet... + (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)) - (when *compile-time-define-macros* - (setf (info :function :compiler-macro-function name) - (coerce def 'function))) + (setf (info :function :compiler-macro-function name) + (coerce def 'function)) (let* ((*current-path* (revert-source-path 'define-compiler-macro)) (fun (ir1-convert-lambda def name))) @@ -2955,82 +2976,7 @@ (ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc))) (when sb!xc:*compile-print* - ;; MNA compiler message patch (compiler-mumble "~&; converted ~S~%" name)))) - -;;; Update the global environment to correspond to the new definition. -(def-ir1-translator %defconstant ((name value doc) start cont - :kind :function) - (let ((name (eval name)) - (newval (eval value))) - (unless (symbolp name) - (compiler-error "constant name not a symbol: ~S" name)) - (when (eq name t) - (compiler-error "The value of T can't be changed.")) - (when (eq name nil) - (compiler-error "Nihil ex nihil. (can't change NIL)")) - (when (keywordp name) - (compiler-error "Keyword values can't be changed.")) - - (let ((kind (info :variable :kind name))) - (case kind - (:constant - ;; Note: This behavior (disparaging any non-EQL modification) - ;; is unpopular, but it is specified by ANSI (i.e. ANSI says - ;; a non-EQL change has undefined consequences). I think it's - ;; a bad idea to encourage nonconforming programming style - ;; even if it's convenient. If people really want things - ;; which are constant in some sense other than EQL, I suggest - ;; either just using DEFVAR (which is what I generally do), - ;; or defining something like this (untested) code: - ;; (DEFMACRO DEFCONSTANT-EQX (SYMBOL EXPR EQX &OPTIONAL DOC) - ;; "This macro is to be used instead of DEFCONSTANT for values - ;; which are appropriately compared using the function given by - ;; the EQX argument instead of EQL." - ;; (LET ((EXPR-TMP (GENSYM "EXPR-TMP-"))) - ;; `(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) - ;; (LET ((,EXPR-TMP ,EXPR)) - ;; (UNLESS (AND (BOUNDP ,SYMBOL) - ;; (CONSTANTP ,SYMBOL) - ;; (FUNCALL ,EQX - ;; (SYMBOL-VALUE ,SYMBOL) - ;; ,EXPR-TMP)) - ;; (DEFCONSTANT ,SYMBOL ,EXPR ,@(WHEN DOC `(,DOC)))))))) - ;; I prefer using DEFVAR, though, first because it's trivial, - ;; and second because using DEFCONSTANT lets the compiler - ;; optimize code by removing indirection, copying the current - ;; value of the constant directly into the code, and for - ;; consed data structures, this optimization can become a - ;; pessimization. (And consed data structures are exactly - ;; where you'd be tempted to use DEFCONSTANT-EQX.) Why is - ;; this a pessimization? It does remove a layer of - ;; indirection, but it makes it hard for the system's - ;; load/dump logic to see that all references to the consed - ;; data structure refer to the same (EQ) object. If you use - ;; something like DEFCONSTANT-EQX, you'll tend to get one - ;; copy of the data structure bound to the symbol, and one - ;; more copy for each file where code refers to the constant. - ;; If you're moderately clever with MAKE-LOAD-FORM, you might - ;; be able to make the copy bound to the symbol at load time - ;; be EQ to the references in code in the same file, but it - ;; seems to be rather tricky to force code in different files - ;; to refer the same copy without doing the DEFVAR thing of - ;; indirection through a symbol. -- WHN 2000-11-02 - (unless (eql newval - (info :variable :constant-value name)) - (compiler-warning "redefining constant ~S as:~% ~S" name newval))) - (:global) - (t - (compiler-warning "redefining ~(~A~) ~S to be a constant" - kind - name)))) - - (setf (info :variable :kind name) :constant) - (setf (info :variable :where-from name) :defined) - (setf (info :variable :constant-value name) newval) - (remhash name *free-variables*)) - - (ir1-convert start cont `(%%defconstant ,name ,value ,doc))) ;;;; defining global functions @@ -3053,8 +2999,7 @@ `(,(car x) . (macro . ,(coerce (cdr x) 'function)))) macros) - :cookie (lexenv-cookie *lexenv*) - :interface-cookie (lexenv-interface-cookie *lexenv*)))) + :policy (lexenv-policy *lexenv*)))) (ir1-convert-lambda `(lambda ,@body) name)))) ;;; Return a lambda that has been "closed" with respect to ENV, @@ -3076,10 +3021,10 @@ (when (eq x (assoc name variables :test #'eq)) (typecase what (cons - (assert (eq (car what) 'macro)) + (aver (eq (car what) 'macro)) (push x symmacs)) (global-var - (assert (eq (global-var-kind what) :special)) + (aver (eq (global-var-kind what) :special)) (push `(special ,name) decls)) (t (return t)))))) nil) @@ -3095,7 +3040,7 @@ (global-var (when (defined-function-p what) (push `(,(car (rassoc (defined-function-inlinep what) - inlinep-translations)) + *inlinep-translations*)) ,name) decls))) (t (return t)))))) @@ -3114,7 +3059,7 @@ (found (find-free-function name "Eh?"))) (note-name-defined name :function) (cond ((not (defined-function-p found)) - (assert (not (info :function :inlinep name))) + (aver (not (info :function :inlinep name))) (let* ((where-from (leaf-where-from found)) (res (make-defined-function :name name @@ -3132,7 +3077,7 @@ ;;; Check a new global function definition for consistency with ;;; previous declaration or definition, and assert argument/result -;;; types if appropriate. This this assertion is suppressed by the +;;; types if appropriate. This assertion is suppressed by the ;;; EXPLICIT-CHECK attribute, which is specified on functions that ;;; check their argument types as a consequence of type dispatching. ;;; This avoids redundant checks such as NUMBERP on the args to +, @@ -3143,8 +3088,15 @@ (info (info :function :info (leaf-name var)))) (assert-definition-type fun type - :error-function #'compiler-warning - :warning-function (cond (info #'compiler-warning) + ;; KLUDGE: Common Lisp is such a dynamic language that in general + ;; all we can do here in general is issue a STYLE-WARNING. It + ;; would be nice to issue a full WARNING in the special case of + ;; of type mismatches within a compilation unit (as in section + ;; 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 + :error-function #'compiler-style-warning + :warning-function (cond (info #'compiler-style-warning) (for-real #'compiler-note) (t nil)) :really-assert @@ -3210,8 +3162,8 @@ (*current-path* (revert-source-path 'defun)) (expansion (unless (eq (info :function :inlinep name) :notinline) (inline-syntactic-closure-lambda lambda)))) - ;; If not in a simple environment or NOTINLINE, then discard any forward - ;; references to this function. + ;; If not in a simple environment or NOTINLINE, then discard any + ;; forward references to this function. (unless expansion (remhash name *free-functions*)) (let* ((var (get-defined-function name)) @@ -3220,8 +3172,8 @@ expansion))) (setf (defined-function-inline-expansion var) expansion) (setf (info :function :inline-expansion name) save-expansion) - ;; If there is a type from a previous definition, blast it, since it is - ;; obsolete. + ;; If there is a type from a previous definition, blast it, + ;; since it is obsolete. (when (eq (leaf-where-from var) :defined) (setf (leaf-type var) (specifier-type 'function))) @@ -3238,5 +3190,4 @@ ,@(when save-expansion `(',save-expansion))))) (when sb!xc:*compile-print* - ;; MNA compiler message patch (compiler-mumble "~&; converted ~S~%" name))))))