From 82e0a78df47685519b12683f495d7ae19e07d3cf Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Fri, 29 Dec 2000 14:36:48 +0000 Subject: [PATCH] 0.6.9.11: more cleanups of optimization policy machinery.. renamed CSPEED slot to COMPILATION-SPEED, and BREVITY slot to INHIBIT-WARNINGS, and got rid of other BREVITY refs STRUCTURE-OBJECT-based POLICY caues too many cold init hassles w/ COPY-POLICY and slot accessors. Use alists instead. Now PROCESS-OPTIMIZE-DECLARATION can look up qualities directly in *POLICY-BASIC-QUALITIES*. --- BUGS | 91 ++++------ NEWS | 2 + package-data-list.lisp-expr | 5 +- src/code/cold-error.lisp | 9 +- src/code/cold-init.lisp | 11 +- src/code/debug.lisp | 2 - src/code/macros.lisp | 3 - src/compiler/checkgen.lisp | 6 +- src/compiler/codegen.lisp | 2 +- src/compiler/debug-dump.lisp | 3 +- src/compiler/early-c.lisp | 112 ++++++++----- src/compiler/fndb.lisp | 2 + src/compiler/gtn.lisp | 3 +- src/compiler/ir1opt.lisp | 4 +- src/compiler/ir1tran.lisp | 61 ++++--- src/compiler/ir1util.lisp | 45 ++--- src/compiler/knownfun.lisp | 10 +- src/compiler/locall.lisp | 7 +- src/compiler/ltn.lisp | 79 +++++---- src/compiler/macros.lisp | 337 ++++++++++++++++++------------------- src/compiler/main.lisp | 13 +- src/compiler/pack.lisp | 3 +- src/compiler/proclaim.lisp | 96 ++++------- src/compiler/represent.lisp | 3 +- src/compiler/seqtran.lisp | 17 +- src/compiler/srctran.lisp | 3 +- src/compiler/typetran.lisp | 11 +- src/compiler/vop.lisp | 382 ++++++++++++++++++++++-------------------- src/pcl/boot.lisp | 1 + 29 files changed, 655 insertions(+), 668 deletions(-) diff --git a/BUGS b/BUGS index 9cba6dc..39c0299 100644 --- a/BUGS +++ b/BUGS @@ -411,61 +411,6 @@ returning an array as first value always. FD-STREAM-MISC-ROUTINE is broken for large files: it says (THE INDEX SIZE) even though SIZE can be larger than INDEX. -37: - In SBCL 0.6.5 (and CMU CL 18b) compiling and loading - (in-package :cl-user) - (declaim (optimize (safety 3) - (debug 3) - (compilation-speed 2) - (space 1) - (speed 2) - #+nil (sb-ext:inhibit-warnings 2))) - (declaim (ftype (function * (values)) emptyvalues)) - (defun emptyvalues (&rest rest) (declare (ignore rest)) (values)) - (defstruct foo x y) - (defgeneric assertoid ((x t))) - (defmethod assertoid ((x t)) "just a placeholder") - (defun bar (ht) - (declare (type hash-table ht)) - (let ((res - (block blockname - (progn - (prog1 - (emptyvalues) - (assertoid (hash-table-count ht))))))) - (unless (typep res 'foo) - (locally - (common-lisp-user::bad-result-from-assertive-typed-fun - 'bar - res))))) - then executing - (bar (make-hash-table)) - causes the failure - Error in KERNEL::UNDEFINED-SYMBOL-ERROR-HANDLER: - the function C::%INSTANCE-TYPEP is undefined. - %INSTANCE-TYPEP is always supposed to be IR1-transformed away, but for - some reason -- the (VALUES) return value declaration? -- the optimizer is - confused and compiles a full call to %INSTANCE-TYPEP (which doesn't exist - as a function) instead. - -37a: - The %INSTANCE-TYPEP problem in bug 37 comes up also when compiling - and loading - (IN-PACKAGE :CL-USER) - (LOCALLY - (DECLARE (OPTIMIZE (SAFETY 3) (SPEED 2) (SPACE 2))) - (DECLAIM (FTYPE (FUNCTION (&REST T) (VALUES)) EMPTYVALUES)) - (DEFUN EMPTYVALUES (&REST REST) - (DECLARE (IGNORE REST)) - (VALUES)) - (DEFSTRUCT DUMMYSTRUCT X Y) - (DEFUN FROB-EMPTYVALUES (X) - (LET ((RES (EMPTYVALUES X X X))) - (UNLESS (TYPEP RES 'DUMMYSTRUCT) - 'EXPECTED-RETURN-VALUE)))) - (ASSERT (EQ (FROB-EMPTYVALUES 11) 'EXPECTED-RETURN-VALUE)) - - 38: DEFMETHOD doesn't check the syntax of &REST argument lists properly, accepting &REST even when it's not followed by an argument name: @@ -762,6 +707,7 @@ Error in function C::GET-LAMBDA-TO-COMPILE: rightward of the correct location. 65: + (probably related to bug #70) As reported by Carl Witty on submit@bugs.debian.org 1999-05-08, compiling this file (in-package "CL-USER") @@ -858,6 +804,7 @@ Error in function C::GET-LAMBDA-TO-COMPILE: or at least issue a warning. 70: + (probably related to bug #65) The compiler doesn't like &OPTIONAL arguments in LABELS and FLET forms. E.g. (DEFUN FIND-BEFORE (ITEM SEQUENCE &KEY (TEST #'EQL)) @@ -884,7 +831,39 @@ Error in function C::GET-LAMBDA-TO-COMPILE: 0.6.9.x in a general cleanup of optimization policy. 72: - (DECLAIM (OPTIMIZE ..)) doesn't work inside LOCALLY. + (DECLAIM (OPTIMIZE ..)) doesn't work properly inside LOCALLY forms. + +73: + PROCLAIM and DECLAIM don't recognize the ANSI abbreviated type + declaration syntax for user-defined types, although DECLARE does. + E.g. + (deftype foo () '(integer 3 19)) + (defvar *foo*) + (declaim (foo *foo*)) ; generates warning + (defun foo+ (x y) + (declare (foo x y)) ; works OK + (+ x y)) + +74: + As noted in the ANSI specification for COERCE, (COERCE 3 'COMPLEX) + gives a result which isn't COMPLEX. The result type optimizer + for COERCE doesn't know this, perhaps because it was written before + ANSI threw this curveball: the optimizer thinks that COERCE always + returns a result of the specified type. Thus while the interpreted + function + (DEFUN TRICKY (X) (TYPEP (COERCE X 'COMPLEX) 'COMPLEX)) + returns the correct result, + (TRICKY 3) => NIL + the compiled function + (COMPILE 'TRICKY) + does not: + (TRICKY 3) => T + +75: + As reported by Martin Atzmueller on sbcl-devel 26 Dec 2000, + ANSI says that WITH-OUTPUT-TO-STRING should have a keyword + :ELEMENT-TYPE, but in sbcl-0.6.9 this is not defined for + WITH-OUTPUT-TO-STRING. KNOWN BUGS RELATED TO THE IR1 INTERPRETER diff --git a/NEWS b/NEWS index 4a2a5f1..b4f3952 100644 --- a/NEWS +++ b/NEWS @@ -632,6 +632,8 @@ changes in sbcl-0.6.10 relative to sbcl-0.6.9: thanks to a patch from Martin Atzmueller. * More compiler warnings in src/runtime/ are gone, thanks to patches from Martin Atzmueller. +* Martin Atzmueller pointed out that bug 37 was fixed by his patches + some time ago. planned incompatible changes in 0.7.x: * The debugger prompt sequence now goes "5]", "5[2]", "5[3]", etc. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 6e5bad0..6f3c24c 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -35,6 +35,7 @@ :doc "private: stuff for implementing ALIENs and friends" :use ("CL") :export ("%CAST" "%DEREF-ADDR" "%HEAP-ALIEN" "%HEAP-ALIEN-ADDR" + "%LOCAL-ALIEN-ADDR" "%LOCAL-ALIEN-FORCED-TO-MEMORY-P" "%SAP-ALIEN" "%SET-DEREF" "%SET-HEAP-ALIEN" "%SET-LOCAL-ALIEN" "%SET-SLOT" "%SLOT-ADDR" "*VALUES-TYPE-OKAY*" "ALIEN-ARRAY-TYPE" @@ -1183,7 +1184,7 @@ is a good idea, but see SB-SYS for blurring of boundaries." "SIMPLE-CONTROL-ERROR" "SIMPLE-FILE-ERROR" "SIMPLE-PROGRAM-ERROR" "SIMPLE-STYLE-WARNING" "STYLE-WARN" - ;; newly exported from former SB!CONDITIONS + ;; symbols from former SB!CONDITIONS "*HANDLER-CLUSTERS*" "*RESTART-CLUSTERS*" "SHOW-CONDITION" "CASE-FAILURE" "NAMESTRING-PARSE-ERROR" "NAMESTRING-PARSE-ERROR-OFFSET" @@ -1198,7 +1199,7 @@ is a good idea, but see SB-SYS for blurring of boundaries." "!READER-COLD-INIT" "STREAM-COLD-INIT-OR-RESET" "!LOADER-COLD-INIT" "!PACKAGE-COLD-INIT" "SIGNAL-COLD-INIT-OR-REINIT" - "!SET-SANE-POLICY-DEFAULTS" "!VM-TYPE-COLD-INIT" + "!POLICY-COLD-INIT-OR-RESANIFY" "!VM-TYPE-COLD-INIT" "!BACKQ-COLD-INIT" "!SHARPM-COLD-INIT" "!CLASS-FINALIZE" "GC-COLD-INIT-OR-REINIT" diff --git a/src/code/cold-error.lisp b/src/code/cold-error.lisp index 80ae1de..b5aaa58 100644 --- a/src/code/cold-error.lisp +++ b/src/code/cold-error.lisp @@ -72,12 +72,9 @@ #!+sb-doc "Invoke the signal facility on a condition formed from datum and arguments. If the condition is not handled, the debugger is invoked." - (/show0 "entering ERROR") - #!+sb-show - (unless *cold-init-complete-p* - (/show0 "ERROR in cold init, arguments=..") - #!+sb-show (dolist (argument arguments) - (sb!impl::cold-print argument))) + (/show0 "entering ERROR, arguments=..") + #!+sb-show (dolist (argument arguments) + (sb!impl::cold-print argument)) (sb!kernel:infinite-error-protect (let ((condition (coerce-to-condition datum arguments 'simple-error 'error)) diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index ede85fd..ad00f27 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -135,9 +135,8 @@ ;; forms of the corresponding source files. (show-and-call !package-cold-init) - - ;; Set sane values for our toplevel forms. - (show-and-call !set-sane-policy-defaults) + (show-and-call !policy-cold-init-or-resanify) + (/show0 "back from !POLICY-COLD-INIT-OR-RESANIFY") ;; KLUDGE: Why are fixups mixed up with toplevel forms? Couldn't ;; fixups be done separately? Wouldn't that be clearer and better? @@ -191,10 +190,10 @@ (/show0 "done with loop over cold toplevel forms and fixups") ;; Set sane values again, so that the user sees sane values instead of - ;; whatever is left over from the last DECLAIM. - (show-and-call !set-sane-policy-defaults) + ;; whatever is left over from the last DECLAIM/PROCLAIM. + (show-and-call !policy-cold-init-or-resanify) - ;; Only do this after top level forms have run, 'cause that's where + ;; Only do this after toplevel forms have run, 'cause that's where ;; DEFTYPEs are. (setf *type-system-initialized* t) diff --git a/src/code/debug.lisp b/src/code/debug.lisp index dde5f75..b7709e1 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -648,8 +648,6 @@ reset to ~S." ;; and when people redirect *ERROR-OUTPUT*, they could ;; reasonably expect to see error messages logged there, ;; regardless of what the debugger does afterwards. - #!+sb-show (sb!kernel:show-condition *debug-condition* - *error-output*) (format *error-output* "~2&debugger invoked on condition of type ~S:~% " (type-of *debug-condition*)) diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 242bf92..e11812d 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -100,9 +100,6 @@ `(eval-when (:compile-toplevel :load-toplevel :execute) (sb!c::%defconstant ',name ,value ',documentation))) -;;; (to avoid "undefined function" warnings when cross-compiling) -(sb!xc:proclaim '(ftype function sb!c::%defconstant)) - ;;; the guts of DEFCONSTANT (defun sb!c::%defconstant (name value doc) (/show "doing %DEFCONSTANT" name value doc) diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index 8e9365d..373ba9f 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -92,7 +92,7 @@ (cond ((policy (continuation-dest cont) (and (<= speed safety) (<= space safety) - (<= cspeed safety))) + (<= compilation-speed safety))) type) (t (let ((min-cost (type-test-cost type)) @@ -488,7 +488,7 @@ (unless (values-types-intersect (node-derived-type use) atype) (mark-error-continuation cont) - (unless (policy node (= brevity 3)) + (unless (policy node (= inhibit-warnings 3)) (do-type-warning use)))))) (when (and (eq type-check t) (not *byte-compiling*)) @@ -506,7 +506,7 @@ (:too-hairy (let* ((context (continuation-dest cont)) (*compiler-error-context* context)) - (when (policy context (>= safety brevity)) + (when (policy context (>= safety inhibit-warnings)) (compiler-note "type assertion too complex to check:~% ~S." (type-specifier (continuation-asserted-type cont))))) diff --git a/src/compiler/codegen.lisp b/src/compiler/codegen.lisp index 12c3ab4..e821679 100644 --- a/src/compiler/codegen.lisp +++ b/src/compiler/codegen.lisp @@ -100,7 +100,7 @@ (policy (lambda-bind (block-home-lambda (block-next (component-head *component-being-compiled*)))) - (or (> speed cspeed) (> space cspeed))))) + (or (> speed compilation-speed) (> space compilation-speed))))) (defun default-segment-inst-hook () #!+sb-show (and *compiler-trace-output* #'trace-instruction)) diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index 8ae879b..008f02d 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -498,8 +498,7 @@ (defun compute-1-debug-function (fun var-locs) (declare (type clambda fun) (type hash-table var-locs)) (let* ((dfun (dfun-from-fun fun)) - (actual-level - (policy-debug (lexenv-policy (node-lexenv (lambda-bind fun))))) + (actual-level (policy (lambda-bind fun) debug)) (level (if #!+sb-dyncount *collect-dynamic-statistics* #!-sb-dyncount nil (max actual-level 2) diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index 4e75b23..9f266bb 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -40,60 +40,84 @@ (def!type sb!kernel::layout-depthoid () '(or index (integer -1 -1))) ;;; a value for an optimization declaration -(def!type sb!c::policy-quality () '(or (rational 0 3) null)) +(def!type policy-quality () '(or (rational 0 3) null)) ;;;; policy stuff -;;; a map from optimization policy quality to corresponding POLICY -;;; slot name, used to automatically keep POLICY-related definitions -;;; in sync even if future maintenance changes POLICY slots -(eval-when (:compile-toplevel :load-toplevel :execute) - (defstruct (policy-quality-slot (:constructor %make-pqs (quality accessor))) - ;; the name of the quality - (quality (required-argument) :type symbol) - ;; the name of the structure slot accessor - (accessor (required-argument) :type symbol)) - (defparameter *policy-quality-slots* - (list (%make-pqs 'speed 'policy-speed) - (%make-pqs 'space 'policy-space) - (%make-pqs 'safety 'policy-safety) - (%make-pqs 'cspeed 'policy-cspeed) - (%make-pqs 'brevity 'policy-brevity) - (%make-pqs 'debug 'policy-debug))) - (defun named-policy-quality-slot (name) - (find name *policy-quality-slots* :key #'policy-quality-slot-quality))) - -;;; A POLICY object holds information about the compilation policy for -;;; a node. See the LEXENV definition for a description of how it is used. -#.`(def!struct (policy - (:copier nil)) ; (but see DEFUN COPY-POLICY) - ,@(mapcar (lambda (pqs) - `(,(policy-quality-slot-quality pqs) nil - :type policy-quality)) - *policy-quality-slots*)) - -;;; an annoyingly hairy way of doing COPY-STRUCTURE on POLICY objects -;;; -;;; (We need this explicit, separate, hairy DEFUN only because we need -;;; to be able to copy POLICY objects in cold init toplevel forms, -;;; earlier than the default copier closure created by DEFSTRUCT -;;; toplevel forms would be available, and earlier than LAYOUT-INFO is -;;; initialized (which is a prerequisite for COPY-STRUCTURE to work).) -#.`(defun copy-policy (policy) - (make-policy - ,@(mapcan (lambda (pqs) - `(,(keywordicate (policy-quality-slot-quality pqs)) - (,(policy-quality-slot-accessor pqs) policy))) - *policy-quality-slots*))) +;;; CMU CL used a special STRUCTURE-OBJECT type POLICY to represent +;;; the state of optimization policy at any point in compilation. This +;;; became a little unwieldy, especially because of cold init issues +;;; for structures and structure accessors, so in SBCL we use an alist +;;; instead. +(deftype policy () 'list) + +;;; names of recognized optimization qualities which don't have +;;; special defaulting behavior +(defvar *policy-basic-qualities*) + +;;; FIXME: I'd like to get rid of DECLAIM OPTIMIZE-INTERFACE in favor +;;; of e.g. (DECLAIM (OPTIMIZE (INTERFACE-SPEED 2) (INTERFACE-SAFETY 3))). +#| +;;; a list of conses (DEFAULTING-QUALITY . DEFAULT-QUALITY) of qualities +;;; which default to other qualities when undefined, e.g. interface +;;; speed defaulting to basic speed +(defvar *policy-defaulting-qualities*) +|# + +(defun optimization-quality-p (name) + (or (member name *policy-basic-qualities*) + ;; FIXME: Uncomment this when OPTIMIZE-INTERFACE goes away. + #|(member name *policy-defaulting-qualities* :key #'car)|#)) ;;; *DEFAULT-POLICY* holds the current global compiler policy -;;; information. Whenever the policy is changed, we copy the structure -;;; so that old uses will still get the old values. +;;; information, as an alist mapping from optimization quality name to +;;; quality value. Inside the scope of declarations, new entries are +;;; added at the head of the alist. +;;; ;;; *DEFAULT-INTERFACE-POLICY* holds any values specified by an ;;; OPTIMIZE-INTERFACE declaration. (declaim (type policy *default-policy* *default-interface-policy*)) (defvar *default-policy*) ; initialized in cold init (defvar *default-interface-policy*) ; initialized in cold init + +;;; This is to be called early in cold init to set things up, and may +;;; also be called again later in cold init in order to reset default +;;; optimization policy back to default values after toplevel PROCLAIM +;;; OPTIMIZE forms have messed with it. +(defun !policy-cold-init-or-resanify () + (setf *policy-basic-qualities* + '(;; ANSI standard qualities + compilation-speed + debug + safety + space + speed + ;; SBCL extensions + ;; + ;; FIXME: INHIBIT-WARNINGS is a misleading name for this. + ;; Perhaps BREVITY would be better. But the ideal name would + ;; have connotations of suppressing not warnings but only + ;; optimization-related notes, which is already mostly the + ;; behavior, and should probably become the exact behavior. + ;; Perhaps INHIBIT-NOTES? + inhibit-warnings)) + (setf *policy-defaulting-qualities* + '((interface-speed . speed) + (interface-safety . safety))) + (setf *default-policy* + (mapcar (lambda (name) + ;; CMU CL didn't use 1 as the default for everything, + ;; but since ANSI says 1 is the ordinary value, we do. + (cons name 1)) + *policy-basic-qualities*)) + (setf *default-interface-policy* + *default-policy*)) +;;; On the cross-compilation host, we initialize the compiler immediately. +#+sb-xc-host (!policy-cold-init-or-resanify) + +;;; Is X the name of an optimization quality? +(defun policy-quality-p (x) + (memq x *policy-basic-qualities*)) ;;; possible values for the INLINE-ness of a function. (deftype inlinep () diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index c1dd7f6..4051d4d 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -32,6 +32,8 @@ ;; lets us preserve distinctions which might not even exist ;; on the cross-compilation host (because ANSI doesn't ;; guarantee that specialized array types exist there). + ;; FIXME: It's actually not clear that COERCE on non-NUMBER types + ;; is FOLDABLE at all. Check this. (movable #-sb-xc-host foldable) :derive-type (result-type-specifier-nth-arg 2)) (defknown list-to-simple-string* (list) simple-string) diff --git a/src/compiler/gtn.lisp b/src/compiler/gtn.lisp index ac9fc62..6795bd2 100644 --- a/src/compiler/gtn.lisp +++ b/src/compiler/gtn.lisp @@ -127,7 +127,8 @@ (defun return-value-efficency-note (tails) (declare (type tail-set tails)) (let ((funs (tail-set-functions tails))) - (when (policy (lambda-bind (first funs)) (> (max speed space) brevity)) + (when (policy (lambda-bind (first funs)) (> (max speed space) + inhibit-warnings)) (dolist (fun funs (let ((*compiler-error-context* (lambda-bind (first funs)))) (compiler-note diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 67c719f..3170104 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -920,8 +920,8 @@ (constrained (function-type-p type)) (table (component-failed-optimizations *component-being-compiled*)) (flame (if (transform-important transform) - (policy node (>= speed brevity)) - (policy node (> speed brevity)))) + (policy node (>= speed inhibit-warnings)) + (policy node (> speed inhibit-warnings)))) (*compiler-error-context* node)) (cond ((not (member (transform-when transform) (if *byte-compiling* diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 15e93f1..b1b9a97 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -819,7 +819,7 @@ type (type-intersection old-type type)))) (cond ((eq int *empty-type*) - (unless (policy nil (= brevity 3)) + (unless (policy nil (= inhibit-warnings 3)) (compiler-warning "The type declarations ~S and ~S for ~S conflict." (type-specifier old-type) (type-specifier type) @@ -927,7 +927,7 @@ name "in an inline or notinline declaration"))) (etypecase found (functional - (when (policy nil (>= speed brevity)) + (when (policy nil (>= speed inhibit-warnings)) (compiler-note "ignoring ~A declaration not at ~ definition of local function:~% ~S" sense name))) @@ -994,7 +994,7 @@ (special (process-special-declaration spec res vars)) (ftype (unless (cdr spec) - (compiler-error "No type specified in FTYPE declaration: ~S." 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 @@ -1034,7 +1034,7 @@ `(values ,@types)) cont res 'values)))) (dynamic-extent - (when (policy nil (> speed brevity)) + (when (policy nil (> speed inhibit-warnings)) (compiler-note "The DYNAMIC-EXTENT declaration is not implemented (ignored).")) res) @@ -1053,15 +1053,15 @@ (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. +;;; 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) @@ -2555,9 +2555,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. ;;; @@ -2576,8 +2576,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 @@ -2598,7 +2598,7 @@ (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 nil (= 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) @@ -2607,26 +2607,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))) @@ -2641,11 +2641,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)) @@ -2679,8 +2674,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))) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 86a7b8d..66d35aa 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -345,13 +345,12 @@ (declare (type lexenv lexenv)) (let ((ipolicy (lexenv-interface-policy lexenv)) (policy (lexenv-policy lexenv))) - (make-policy - :speed (or (policy-speed ipolicy) (policy-speed policy)) - :space (or (policy-space ipolicy) (policy-space policy)) - :safety (or (policy-safety ipolicy) (policy-safety policy)) - :cspeed (or (policy-cspeed ipolicy) (policy-cspeed policy)) - :brevity (or (policy-brevity ipolicy) (policy-brevity policy)) - :debug (or (policy-debug ipolicy) (policy-debug policy))))) + (let ((result policy)) + (dolist (quality '(speed safety space)) + (let ((iquality-entry (assoc quality ipolicy))) + (when iquality-entry + (push iquality-entry result)))) + result))) ;;;; flow/DFO/component hackery @@ -890,7 +889,7 @@ (unless (or (leaf-ever-used var) (lambda-var-ignorep var)) (let ((*compiler-error-context* (lambda-bind fun))) - (unless (policy *compiler-error-context* (= brevity 3)) + (unless (policy *compiler-error-context* (= inhibit-warnings 3)) ;; ANSI section "3.2.5 Exceptional Situations in the Compiler" ;; requires this to be a STYLE-WARNING. (compiler-style-warning "The variable ~S is defined but never used." @@ -1637,8 +1636,8 @@ ;;; out how to compile something as efficiently as it liked.) (defun compiler-note (format-string &rest format-args) (unless (if *compiler-error-context* - (policy *compiler-error-context* (= brevity 3)) - (policy nil (= brevity 3))) + (policy *compiler-error-context* (= inhibit-warnings 3)) + (policy nil (= inhibit-warnings 3))) (incf *compiler-note-count*) (print-compiler-message (format nil "note: ~A" format-string) format-args)) @@ -1730,7 +1729,7 @@ problem is a missing definition (as opposed to a typo in the use.)") ;;; Make an entry in the *UNDEFINED-WARNINGS* describing a reference -;;; to Name of the specified Kind. If we have exceeded the warning +;;; to NAME of the specified KIND. If we have exceeded the warning ;;; limit, then just increment the count, otherwise note the current ;;; error context. ;;; @@ -1738,14 +1737,18 @@ ;;; WITH-COMPILATION-UNIT, which can potentially be invoked outside ;;; the compiler, hence the BOUNDP check. (defun note-undefined-reference (name kind) - (unless (and (boundp '*lexenv*) - ;; FIXME: I'm pretty sure the BREVITY test below isn't - ;; a good idea; we should have BREVITY affect compiler - ;; notes, not STYLE-WARNINGs. And I'm not sure what the - ;; BOUNDP '*LEXENV* test above is for; it's likely - ;; a good idea, but it probably deserves an explanatory - ;; comment. - (policy nil (= brevity 3))) + (unless (and + ;; (POLICY NIL ..) isn't well-defined except in IR1 + ;; conversion. This BOUNDP test seems to be a test for + ;; whether IR1 conversion is going on. + (boundp '*lexenv*) + ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below + ;; isn't a good idea; we should have INHIBIT-WARNINGS + ;; affect compiler notes, not STYLE-WARNINGs. And I'm not + ;; sure what the BOUNDP '*LEXENV* test above is for; it's + ;; likely a good idea, but it probably deserves an + ;; explanatory comment. + (policy nil (= inhibit-warnings 3))) (let* ((found (dolist (warning *undefined-warnings* nil) (when (and (equal (undefined-warning-name warning) name) (eq (undefined-warning-kind warning) kind)) @@ -1827,8 +1830,8 @@ (incf (event-info-count info)) (when (and (>= (event-info-level info) *event-note-threshold*) (if node - (policy node (= brevity 0)) - (policy nil (= brevity 0)))) + (policy node (= inhibit-warnings 0)) + (policy nil (= inhibit-warnings 0)))) (let ((*compiler-error-context* node)) (compiler-note (event-info-description info)))) diff --git a/src/compiler/knownfun.lisp b/src/compiler/knownfun.lisp index d4929cc..e398372 100644 --- a/src/compiler/knownfun.lisp +++ b/src/compiler/knownfun.lisp @@ -118,16 +118,16 @@ ;;; The TRANSFORM structure represents an IR1 transform. (defstruct transform - ;; The function-type which enables this transform. + ;; the function-type which enables this transform (type (required-argument) :type ctype) - ;; The transformation function. Takes the Combination node and Returns a + ;; the transformation function. Takes the COMBINATION node and returns a ;; lambda, or throws out. (function (required-argument) :type function) - ;; String used in efficency notes. + ;; string used in efficency notes (note (required-argument) :type string) - ;; T if we should spew a failure note even if speed=brevity. + ;; T if we should emit a failure note even if SPEED=INHIBIT-WARNINGS. (important nil :type (member t nil)) - ;; Usable for byte code, native code, or both. + ;; usable for byte code, native code, or both (when :native :type (member :byte :native :both))) (defprinter (transform) type note important when) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 42325f9..14e699c 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -280,13 +280,13 @@ (values)) -;;; If policy is auspicious, Call is not in an XEP, and we don't seem +;;; If policy is auspicious, CALL is not in an XEP, and we don't seem ;;; to be in an infinite recursive loop, then change the reference to ;;; reference a fresh copy. We return whichever function we decide to ;;; reference. (defun maybe-expand-local-inline (fun ref call) (if (and (policy call - (and (>= speed space) (>= speed cspeed))) + (and (>= speed space) (>= speed compilation-speed))) (not (eq (functional-kind (node-home-lambda call)) :external)) (not *converting-for-interpreter*) (inline-expansion-ok call)) @@ -519,7 +519,8 @@ (arglist (optional-dispatch-arglist fun)) (args (combination-args call)) (more (nthcdr max args)) - (flame (policy call (or (> speed brevity) (> space brevity)))) + (flame (policy call (or (> speed inhibit-warnings) + (> space inhibit-warnings)))) (loser nil) (temps (make-gensym-list max)) (more-temps (make-gensym-list (length more)))) diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index ae6d48f..708c446 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -18,24 +18,27 @@ ;;; Return the policies keyword indicated by the node policy. (defun translation-policy (node) (declare (type node node)) - (let* ((policy (lexenv-policy (node-lexenv node))) - (safety (policy-safety policy)) - (space (max (policy-space policy) - (policy-cspeed policy))) - (speed (policy-speed policy))) - (if (zerop safety) - (if (>= speed space) :fast :small) - (if (>= speed space) :fast-safe :safe)))) - -;;; Return true if Policy is a safe policy. + (policy node + (let ((eff-space (max space + ;; on the theory that if the code is + ;; smaller, it will take less time to + ;; compile (could lose if the smallest + ;; case is out of line, and must + ;; allocate many linkage registers): + compilation-speed))) + (if (zerop safety) + (if (>= speed eff-space) :fast :small) + (if (>= speed eff-space) :fast-safe :safe))))) + +;;; Return true if POLICY is a safe policy. #!-sb-fluid (declaim (inline policy-safe-p)) (defun policy-safe-p (policy) (declare (type policies policy)) (or (eq policy :safe) (eq policy :fast-safe))) -;;; Called when an unsafe policy indicates that no type check should be done -;;; on CONT. We delete the type check unless it is :ERROR (indicating a -;;; compile-time type error.) +;;; Called when an unsafe policy indicates that no type check should +;;; be done on CONT. We delete the type check unless it is :ERROR +;;; (indicating a compile-time type error.) #!-sb-fluid (declaim (inline flush-type-check)) (defun flush-type-check (cont) (declare (type continuation cont)) @@ -49,9 +52,9 @@ (declare (type continuation cont)) (ir2-continuation-primitive-type (continuation-info cont))) -;;; Return true if a constant Leaf is of a type which we can legally -;;; directly reference in code. Named constants with arbitrary pointer values -;;; cannot, since we must preserve EQLness. +;;; Return true if a constant LEAF is of a type which we can legally +;;; directly reference in code. Named constants with arbitrary pointer +;;; values cannot, since we must preserve EQLness. (defun legal-immediate-constant-p (leaf) (declare (type constant leaf)) (or (null (leaf-name leaf)) @@ -60,8 +63,8 @@ (symbol (symbol-package (constant-value leaf))) (t nil)))) -;;; If Cont is used only by a Ref to a leaf that can be delayed, then return -;;; the leaf, otherwise return NIL. +;;; If CONT is used only by a REF to a leaf that can be delayed, then +;;; return the leaf, otherwise return NIL. (defun continuation-delayed-leaf (cont) (declare (type continuation cont)) (let ((use (continuation-use cont))) @@ -72,12 +75,12 @@ (constant (if (legal-immediate-constant-p leaf) leaf nil)) ((or functional global-var) nil)))))) -;;; Annotate a normal single-value continuation. If its only use is a ref -;;; that we are allowed to delay the evaluation of, then we mark the -;;; continuation for delayed evaluation, otherwise we assign a TN to hold the -;;; continuation's value. If the continuation has a type check, we make the TN -;;; according to the proven type to ensure that the possibly erroneous value -;;; can be represented. +;;; Annotate a normal single-value continuation. If its only use is a +;;; ref that we are allowed to delay the evaluation of, then we mark +;;; the continuation for delayed evaluation, otherwise we assign a TN +;;; to hold the continuation's value. If the continuation has a type +;;; check, we make the TN according to the proven type to ensure that +;;; the possibly erroneous value can be represented. (defun annotate-1-value-continuation (cont) (declare (type continuation cont)) (let ((info (continuation-info cont))) @@ -95,16 +98,17 @@ (single-value-type (continuation-proven-type cont))))))))) (values)) -;;; Make an IR2-Continuation corresponding to the continuation type and then -;;; do Annotate-1-Value-Continuation. If Policy isn't a safe policy, then we -;;; clear the type-check flag. -(defun annotate-ordinary-continuation (cont policy) +;;; Make an IR2-CONTINUATION corresponding to the continuation type +;;; and then do ANNOTATE-1-VALUE-CONTINUATION. If POLICY-KEYWORD isn't +;;; a safe policy keyword, then we clear the TYPE-CHECK flag. +(defun annotate-ordinary-continuation (cont policy-keyword) (declare (type continuation cont) - (type policies policy)) + (type policies policy-keyword)) (let ((info (make-ir2-continuation (primitive-type (continuation-type cont))))) (setf (continuation-info cont) info) - (unless (policy-safe-p policy) (flush-type-check cont)) + (unless (policy-safe-p policy-keyword) + (flush-type-check cont)) (annotate-1-value-continuation cont)) (values)) @@ -112,12 +116,13 @@ ;;; reference is to a global function and Delay is true, then we delay ;;; the reference, otherwise we annotate for a single value. ;;; -;;; Unlike for an argument, we only clear the type check flag when the policy -;;; is unsafe, since the check for a valid function object must be done before -;;; the call. +;;; Unlike for an argument, we only clear the type check flag when the +;;; policy is unsafe, since the check for a valid function object must +;;; be done before the call. (defun annotate-function-continuation (cont policy &optional (delay t)) (declare (type continuation cont) (type policies policy)) - (unless (policy-safe-p policy) (flush-type-check cont)) + (unless (policy-safe-p policy) + (flush-type-check cont)) (let* ((ptype (primitive-type (continuation-type cont))) (tn-ptype (if (member (continuation-type-check cont) '(:deleted nil)) ptype @@ -217,7 +222,7 @@ (let* ((dest (continuation-dest cont)) (*compiler-error-context* dest)) (when (and (policy-safe-p policy) - (policy dest (>= safety brevity))) + (policy dest (>= safety inhibit-warnings))) (compiler-note "unable to check type assertion in unknown-values ~ context:~% ~S" (continuation-asserted-type cont)))) @@ -739,7 +744,7 @@ (collect ((losers)) (let ((safe-p (policy-safe-p policy)) - (verbose-p (policy call (= brevity 0))) + (verbose-p (policy call (= inhibit-warnings 0))) (max-cost (- (template-cost (or template (template-or-lose 'call-named))) @@ -846,7 +851,7 @@ ;; restrictions and our policy enables efficiency notes, then we call ;; Note-Rejected-Templates. (when (and rejected - (policy call (> speed brevity))) + (policy call (> speed inhibit-warnings))) (note-rejected-templates call policy template)) ;; If we are forced to do a full call, we check to see whether the ;; function called is the same as the current function. If so, we diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index e510d5b..956f59e 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -26,20 +26,28 @@ ;;;; the POLICY macro -;;; a helper function for the POLICY macro: Return a list of -;;; POLICY-QUALITY-SLOT objects corresponding to the qualities which -;;; appear in EXPR. (eval-when (:compile-toplevel :load-toplevel :execute) - (defun policy-quality-slots-used-by (expr) - (let ((result nil)) - (labels ((recurse (x) - (if (listp x) - (map nil #'recurse x) - (let ((pqs (named-policy-quality-slot x))) - (when pqs - (pushnew pqs result)))))) - (recurse expr) - result)))) + +;;; a helper function for the POLICY macro: Look up a named optimization +;;; quality in POLICY. +(declaim (ftype (function (policy symbol) policy-quality))) +(defun policy-quality (policy quality-name) + (the policy-quality + (cdr (assoc quality-name policy)))) + +;;; A helper function for the POLICY macro: Return a list of symbols +;;; naming the qualities which appear in EXPR. +(defun policy-qualities-used-by (expr) + (let ((result nil)) + (labels ((recurse (x) + (if (listp x) + (map nil #'recurse x) + (when (policy-quality-p x) + (pushnew x result))))) + (recurse expr) + result))) + +) ; EVAL-WHEN ;;; syntactic sugar for querying optimization policy qualities ;;; @@ -49,19 +57,16 @@ ;;; well-defined during IR1 conversion.) ;;; ;;; EXPR is a form which accesses the policy values by referring to -;;; them by name, e.g. SPEED. +;;; them by name, e.g. (> SPEED SPACE). (defmacro policy (node expr) (let* ((n-policy (gensym)) - (binds (mapcar - (lambda (pqs) - `(,(policy-quality-slot-quality pqs) - (,(policy-quality-slot-accessor pqs) ,n-policy))) - (policy-quality-slots-used-by expr)))) + (binds (mapcar (lambda (name) + `(,name (policy-quality ,n-policy ',name))) + (policy-qualities-used-by expr)))) (/show "in POLICY" expr binds) - `(let* ((,n-policy (lexenv-policy - ,(if node - `(node-lexenv ,node) - '*lexenv*))) + `(let* ((,n-policy (lexenv-policy ,(if node + `(node-lexenv ,node) + '*lexenv*))) ,@binds) ,expr))) @@ -389,75 +394,71 @@ ;;;; DEFTRANSFORM -;;; Parse the lambda-list and generate code to test the policy and -;;; automatically create the result lambda. +;;; Define an IR1 transformation for NAME. An IR1 transformation +;;; computes a lambda that replaces the function variable reference +;;; for the call. A transform may pass (decide not to transform the +;;; call) by calling the GIVE-UP-IR1-TRANSFORM function. LAMBDA-LIST +;;; both determines how the current call is parsed and specifies the +;;; LAMBDA-LIST for the resulting lambda. +;;; +;;; We parse the call and bind each of the lambda-list variables to +;;; the continuation which represents the value of the argument. When +;;; parsing the call, we ignore the defaults, and always bind the +;;; variables for unsupplied arguments to NIL. If a required argument +;;; is missing, an unknown keyword is supplied, or an argument keyword +;;; is not a constant, then the transform automatically passes. The +;;; DECLARATIONS apply to the bindings made by DEFTRANSFORM at +;;; transformation time, rather than to the variables of the resulting +;;; lambda. Bound-but-not-referenced warnings are suppressed for the +;;; lambda-list variables. The DOC-STRING is used when printing +;;; efficiency notes about the defined transform. +;;; +;;; Normally, the body evaluates to a form which becomes the body of +;;; an automatically constructed lambda. We make LAMBDA-LIST the +;;; lambda-list for the lambda, and automatically insert declarations +;;; of the argument and result types. If the second value of the body +;;; is non-null, then it is a list of declarations which are to be +;;; inserted at the head of the lambda. Automatic lambda generation +;;; may be inhibited by explicitly returning a lambda from the body. +;;; +;;; The ARG-TYPES and RESULT-TYPE are used to create a function type +;;; which the call must satisfy before transformation is attempted. +;;; The function type specifier is constructed by wrapping (FUNCTION +;;; ...) around these values, so the lack of a restriction may be +;;; specified by omitting the argument or supplying *. The argument +;;; syntax specified in the ARG-TYPES need not be the same as that in +;;; the LAMBDA-LIST, but the transform will never happen if the +;;; syntaxes can't be satisfied simultaneously. If there is an +;;; existing transform for the same function that has the same type, +;;; then it is replaced with the new definition. +;;; +;;; These are the legal keyword options: +;;; :RESULT - A variable which is bound to the result continuation. +;;; :NODE - A variable which is bound to the combination node for the call. +;;; :POLICY - A form which is supplied to the POLICY macro to determine +;;; whether this transformation is appropriate. If the result +;;; is false, then the transform automatically gives up. +;;; :EVAL-NAME +;;; - The name and argument/result types are actually forms to be +;;; evaluated. Useful for getting closures that transform similar +;;; functions. +;;; :DEFUN-ONLY +;;; - Don't actually instantiate a transform, instead just DEFUN +;;; Name with the specified transform definition function. This +;;; may be later instantiated with %DEFTRANSFORM. +;;; :IMPORTANT +;;; - If supplied and non-NIL, note this transform as ``important,'' +;;; which means efficiency notes will be generated when this +;;; transform fails even if INHIBIT-WARNINGS=SPEED (but not if +;;; INHIBIT-WARNINGS>SPEED). +;;; :WHEN {:NATIVE | :BYTE | :BOTH} +;;; - Indicates whether this transform applies to native code, +;;; byte-code or both (default :native.) (defmacro deftransform (name (lambda-list &optional (arg-types '*) (result-type '*) &key result policy node defun-only eval-name important (when :native)) &body body-decls-doc) - #!+sb-doc - "Deftransform Name (Lambda-List [Arg-Types] [Result-Type] {Key Value}*) - Declaration* [Doc-String] Form* - Define an IR1 transformation for NAME. An IR1 transformation computes a - lambda that replaces the function variable reference for the call. A - transform may pass (decide not to transform the call) by calling the - GIVE-UP-IR1-TRANSFORM function. LAMBDA-LIST both determines how the - current call is parsed and specifies the LAMBDA-LIST for the resulting - lambda. - - We parse the call and bind each of the lambda-list variables to the - continuation which represents the value of the argument. When parsing - the call, we ignore the defaults, and always bind the variables for - unsupplied arguments to NIL. If a required argument is missing, an - unknown keyword is supplied, or an argument keyword is not a constant, - then the transform automatically passes. The DECLARATIONS apply to the - bindings made by DEFTRANSFORM at transformation time, rather than to - the variables of the resulting lambda. Bound-but-not-referenced - warnings are suppressed for the lambda-list variables. The DOC-STRING - is used when printing efficiency notes about the defined transform. - - Normally, the body evaluates to a form which becomes the body of an - automatically constructed lambda. We make LAMBDA-LIST the lambda-list - for the lambda, and automatically insert declarations of the argument - and result types. If the second value of the body is non-null, then it - is a list of declarations which are to be inserted at the head of the - lambda. Automatic lambda generation may be inhibited by explicitly - returning a lambda from the body. - - The ARG-TYPES and RESULT-TYPE are used to create a function type - which the call must satisfy before transformation is attempted. The - function type specifier is constructed by wrapping (FUNCTION ...) - around these values, so the lack of a restriction may be specified by - omitting the argument or supplying *. The argument syntax specified in - the ARG-TYPES need not be the same as that in the LAMBDA-LIST, but the - transform will never happen if the syntaxes can't be satisfied - simultaneously. If there is an existing transform for the same - function that has the same type, then it is replaced with the new - definition. - - These are the legal keyword options: - :Result - A variable which is bound to the result continuation. - :Node - A variable which is bound to the combination node for the call. - :Policy - A form which is supplied to the POLICY macro to determine whether - this transformation is appropriate. If the result is false, then - the transform automatically passes. - :Eval-Name - - The name and argument/result types are actually forms to be - evaluated. Useful for getting closures that transform similar - functions. - :Defun-Only - - Don't actually instantiate a transform, instead just DEFUN - Name with the specified transform definition function. This may - be later instantiated with %DEFTRANSFORM. - :Important - - If supplied and non-NIL, note this transform as ``important,'' - which means efficiency notes will be generated when this - transform fails even if brevity=speed (but not if brevity>speed) - :When {:Native | :Byte | :Both} - - Indicates whether this transform applies to native code, - byte-code or both (default :native.)" - (when (and eval-name defun-only) (error "can't specify both DEFUN-ONLY and EVAL-NAME")) (multiple-value-bind (body decls doc) (parse-body body-decls-doc) @@ -511,56 +512,58 @@ ;;; ;;; FIXME: DEFKNOWN is needed only at build-the-system time. Figure ;;; out some way to keep it from appearing in the target system. +;;; +;;; Declare the function NAME to be a known function. We construct a +;;; type specifier for the function by wrapping (FUNCTION ...) around +;;; the ARG-TYPES and RESULT-TYPE. ATTRIBUTES is an unevaluated list +;;; of boolean attributes of the function. These attributes are +;;; meaningful here: +;;; +;;; CALL +;;; May call functions that are passed as arguments. In order +;;; to determine what other effects are present, we must find +;;; the effects of all arguments that may be functions. +;;; +;;; UNSAFE +;;; May incorporate arguments in the result or somehow pass +;;; them upward. +;;; +;;; UNWIND +;;; May fail to return during correct execution. Errors +;;; are O.K. +;;; +;;; ANY +;;; The (default) worst case. Includes all the other bad +;;; things, plus any other possible bad thing. +;;; +;;; FOLDABLE +;;; May be constant-folded. The function has no side effects, +;;; but may be affected by side effects on the arguments. E.g. +;;; SVREF, MAPC. +;;; +;;; FLUSHABLE +;;; May be eliminated if value is unused. The function has +;;; no side effects except possibly CONS. If a function is +;;; defined to signal errors, then it is not flushable even +;;; if it is movable or foldable. +;;; +;;; MOVABLE +;;; May be moved with impunity. Has no side effects except +;;; possibly CONS, and is affected only by its arguments. +;;; +;;; PREDICATE +;;; A true predicate likely to be open-coded. This is a +;;; hint to IR1 conversion that it should ensure calls always +;;; appear as an IF test. Not usually specified to DEFKNOWN, +;;; since this is implementation dependent, and is usually +;;; automatically set by the DEFINE-VOP :CONDITIONAL option. +;;; +;;; NAME may also be a list of names, in which case the same +;;; information is given to all the names. The keywords specify the +;;; initial values for various optimizers that the function might +;;; have. (defmacro defknown (name arg-types result-type &optional (attributes '(any)) &rest keys) - #!+sb-doc - "Defknown Name Arg-Types Result-Type [Attributes] {Key Value}* - Declare the function Name to be a known function. We construct a type - specifier for the function by wrapping (FUNCTION ...) around the Arg-Types - and Result-Type. Attributes is an unevaluated list of boolean - attributes of the function. These attributes are meaningful here: - call - May call functions that are passed as arguments. In order - to determine what other effects are present, we must find - the effects of all arguments that may be functions. - - unsafe - May incorporate arguments in the result or somehow pass - them upward. - - unwind - May fail to return during correct execution. Errors - are O.K. - - any - The (default) worst case. Includes all the other bad - things, plus any other possible bad thing. - - foldable - May be constant-folded. The function has no side effects, - but may be affected by side effects on the arguments. E.g. - SVREF, MAPC. - - flushable - May be eliminated if value is unused. The function has - no side effects except possibly CONS. If a function is - defined to signal errors, then it is not flushable even - if it is movable or foldable. - - movable - May be moved with impunity. Has no side effects except - possibly CONS,and is affected only by its arguments. - - predicate - A true predicate likely to be open-coded. This is a - hint to IR1 conversion that it should ensure calls always - appear as an IF test. Not usually specified to Defknown, - since this is implementation dependent, and is usually - automatically set by the Define-VOP :Conditional option. - - Name may also be a list of names, in which case the same information - is given to all the names. The keywords specify the initial values - for various optimizers that the function might have." (when (and (intersection attributes '(any call unwind)) (intersection attributes '(movable))) (error "function cannot have both good and bad attributes: ~S" attributes)) @@ -575,31 +578,30 @@ attributes)) ,@keys)) -;;; Create a function which parses combination args according to -;;; LAMBDA-LIST, optionally storing it in a FUNCTION-INFO slot. +;;; Create a function which parses combination args according to WHAT +;;; and LAMBDA-LIST, where WHAT is either a function name or a list +;;; (FUNCTION-NAME KIND) and does some KIND of optimization. +;;; +;;; The FUNCTION-NAME must name a known function. LAMBDA-LIST is used +;;; to parse the arguments to the combination as in DEFTRANSFORM. If +;;; the argument syntax is invalid or there are non-constant keys, +;;; then we simply return NIL. +;;; +;;; The function is DEFUN'ed as FUNCTION-KIND-OPTIMIZER. Possible +;;; kinds are DERIVE-TYPE, OPTIMIZER, LTN-ANNOTATE and IR2-CONVERT. If +;;; a symbol is specified instead of a (FUNCTION KIND) list, then we +;;; just do a DEFUN with the symbol as its name, and don't do anything +;;; with the definition. This is useful for creating optimizers to be +;;; passed by name to DEFKNOWN. +;;; +;;; If supplied, NODE-VAR is bound to the combination node being +;;; optimized. If additional VARS are supplied, then they are used as +;;; the rest of the optimizer function's lambda-list. LTN-ANNOTATE +;;; methods are passed an additional POLICY argument, and IR2-CONVERT +;;; methods are passed an additional IR2-BLOCK argument. (defmacro defoptimizer (what (lambda-list &optional (n-node (gensym)) &rest vars) &body body) - #!+sb-doc - "Defoptimizer (Function Kind) (Lambda-List [Node-Var] Var*) - Declaration* Form* - Define some Kind of optimizer for the named Function. Function must be a - known function. Lambda-List is used to parse the arguments to the - combination as in Deftransform. If the argument syntax is invalid or there - are non-constant keys, then we simply return NIL. - - The function is DEFUN'ed as Function-Kind-OPTIMIZER. Possible kinds are - DERIVE-TYPE, OPTIMIZER, LTN-ANNOTATE and IR2-CONVERT. If a symbol is - specified instead of a (Function Kind) list, then we just do a DEFUN with the - symbol as its name, and don't do anything with the definition. This is - useful for creating optimizers to be passed by name to DEFKNOWN. - - If supplied, Node-Var is bound to the combination node being optimized. If - additional Vars are supplied, then they are used as the rest of the optimizer - function's lambda-list. LTN-ANNOTATE methods are passed an additional POLICY - argument, and IR2-CONVERT methods are passed an additional IR2-BLOCK - argument." - (let ((name (if (symbolp what) what (symbolicate (first what) "-" (second what) "-OPTIMIZER")))) @@ -616,18 +618,17 @@ ;;;; IR groveling macros +;;; Iterate over the blocks in a component, binding BLOCK-VAR to each +;;; block in turn. The value of ENDS determines whether to iterate +;;; over dummy head and tail blocks: +;;; NIL -- Skip Head and Tail (the default) +;;; :HEAD -- Do head but skip tail +;;; :TAIL -- Do tail but skip head +;;; :BOTH -- Do both head and tail +;;; +;;; If supplied, RESULT-FORM is the value to return. (defmacro do-blocks ((block-var component &optional ends result) &body body) #!+sb-doc - "Do-Blocks (Block-Var Component [Ends] [Result-Form]) {Declaration}* {Form}* - Iterate over the blocks in a component, binding Block-Var to each block in - turn. The value of Ends determines whether to iterate over dummy head and - tail blocks: - NIL -- Skip Head and Tail (the default) - :Head -- Do head but skip tail - :Tail -- Do tail but skip head - :Both -- Do both head and tail - - If supplied, Result-Form is the value to return." (unless (member ends '(nil :head :tail :both)) (error "losing ENDS value: ~S" ends)) (let ((n-component (gensym)) @@ -1114,4 +1115,4 @@ (defmacro position-or-lose (&rest args) `(or (position ,@args) - (error "Shouldn't happen?"))) + (error "shouldn't happen?"))) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 24dc333..5fb8f4d 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -384,7 +384,7 @@ (entry-analyze component) (ir2-convert component) - (when (policy nil (>= speed cspeed)) + (when (policy nil (>= speed compilation-speed)) (maybe-mumble "copy ") (copy-propagate component)) @@ -812,10 +812,9 @@ (declare (type source-info info)) (cond ((source-info-stream info)) (t - (setq *package* *initial-package*) - (setq *default-policy* (copy-policy *initial-policy*)) - (setq *default-interface-policy* - (copy-policy *initial-interface-policy*)) + (setf *package* *initial-package* + *default-policy* *initial-policy* + *default-interface-policy* *initial-interface-policy*) (let* ((finfo (first (source-info-current-file info))) (name (file-info-name finfo))) (setq sb!xc:*compile-file-truename* name) @@ -1360,8 +1359,8 @@ (*initial-package* (sane-package)) (*initial-policy* *default-policy*) (*initial-interface-policy* *default-interface-policy*) - (*default-policy* (copy-policy *initial-policy*)) - (*default-interface-policy* (copy-policy *initial-interface-policy*)) + (*default-policy* *initial-policy*) + (*default-interface-policy* *initial-interface-policy*) (*lexenv* (make-null-lexenv)) (*converting-for-interpreter* nil) (*source-info* info) diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp index ef8b22f..a001be5 100644 --- a/src/compiler/pack.lisp +++ b/src/compiler/pack.lisp @@ -1419,7 +1419,8 @@ (defun pack (component) (assert (not *in-pack*)) (let ((*in-pack* t) - (optimize (policy nil (or (>= speed cspeed) (>= space cspeed)))) + (optimize (policy nil (or (>= speed compilation-speed) + (>= space compilation-speed)))) (2comp (component-info component))) (init-sb-vectors component) diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 990c6ce..d835f98 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -14,36 +14,15 @@ (in-package "SB!C") -;;; !COLD-INIT calls this twice to initialize policy, once before -;;; any toplevel forms are executed, then again to undo any lingering -;;; effects of toplevel DECLAIMs. -(!begin-collecting-cold-init-forms) -(!cold-init-forms - (setf *default-policy* - (make-policy :safety 1 - :speed 1 - :space 1 - :cspeed 1 - :brevity 1 - ;; Note: CMU CL had a default of 2 for DEBUG and 1 for all - ;; the other qualities. SBCL uses a default of 1 for every - ;; quality, because the ANSI documentation for the - ;; OPTIMIZE declaration says that 1 is "the neutral - ;; value", and it seems natural for the neutral value to - ;; be the default. - :debug 1)) - (setf *default-interface-policy* - (make-policy))) -(!defun-from-collected-cold-init-forms !set-sane-policy-defaults) - ;;; A list of UNDEFINED-WARNING structures representing references to unknown ;;; stuff which came up in a compilation unit. (defvar *undefined-warnings*) (declaim (list *undefined-warnings*)) -;;; Check that Name is a valid function name, returning the name if OK, and -;;; doing an error if not. In addition to checking for basic well-formedness, -;;; we also check that symbol names are not NIL or the name of a special form. +;;; Check that NAME is a valid function name, returning the name if +;;; OK, and doing an error if not. In addition to checking for basic +;;; well-formedness, we also check that symbol names are not NIL or +;;; the name of a special form. (defun check-function-name (name) (typecase name (list @@ -59,12 +38,12 @@ (t (compiler-error "illegal function name: ~S" name)))) -;;; Called to do something about SETF functions that overlap with SETF -;;; macros. Perhaps we should interact with the user to see whether -;;; the macro should be blown away, but for now just give a warning. -;;; Due to the weak semantics of the (SETF FUNCTION) name, we can't -;;; assume that they aren't just naming a function (SETF FOO) for the -;;; heck of it. NAME is already known to be well-formed. +;;; This is called to do something about SETF functions that overlap +;;; with SETF macros. Perhaps we should interact with the user to see +;;; whether the macro should be blown away, but for now just give a +;;; warning. Due to the weak semantics of the (SETF FUNCTION) name, we +;;; can't assume that they aren't just naming a function (SETF FOO) +;;; for the heck of it. NAME is already known to be well-formed. (defun note-if-setf-function-and-macro (name) (when (consp name) (when (or (info :setf :inverse name) @@ -92,33 +71,24 @@ ;;; defaulted from the POLICY argument. (declaim (ftype (function (list policy) policy) process-optimize-declaration)) (defun process-optimize-declaration (spec policy) - (let ((res (copy-policy policy))) - (dolist (quality (cdr spec)) - (let ((quality (if (atom quality) (list quality 3) quality))) - (if (and (consp (cdr quality)) (null (cddr quality)) - (typep (second quality) 'real) (<= 0 (second quality) 3)) - (let ((value (rational (second quality)))) - (case (first quality) - (speed (setf (policy-speed res) value)) - (space (setf (policy-space res) value)) - (safety (setf (policy-safety res) value)) - (compilation-speed (setf (policy-cspeed res) value)) - ;; FIXME: BREVITY is an undocumented name for it, - ;; should go away. And INHIBIT-WARNINGS is a - ;; misleading name for it. Perhaps BREVITY would be - ;; better. But the ideal name would have connotations - ;; of suppressing only optimization-related notes, - ;; which I think is the behavior. Perhaps - ;; INHIBIT-NOTES? - ((inhibit-warnings brevity) (setf (policy-brevity res) value)) - ((debug-info debug) (setf (policy-debug res) value)) - (t - (compiler-warning "unknown optimization quality ~S in ~S" - (car quality) spec)))) - (compiler-warning - "malformed optimization quality specifier ~S in ~S" - quality spec)))) - res)) + (let ((result policy)) ; may have new entries pushed on it below + (dolist (q-and-v-or-just-q (cdr spec)) + (multiple-value-bind (quality raw-value) + (if (atom q-and-v-or-just-q) + (values q-and-v-or-just-q 3) + (destructuring-bind (quality raw-value) q-and-v-or-just-q + (values quality raw-value))) + (cond ((not (policy-quality-p quality)) + (compiler-warning "ignoring unknown optimization quality ~ + ~S in ~S" + quality spec)) + ((not (and (typep raw-value 'real) (<= 0 raw-value 3))) + (compiler-warning "ignoring bad optimization value ~S in ~S" + raw-value spec)) + (t + (push (cons quality (rational raw-value)) + result))))) + result)) (defun sb!xc:proclaim (form) (unless (consp form) @@ -250,15 +220,7 @@ (setf (info :declaration :recognized decl) t))) (t (cond ((member kind *standard-type-names*) - (sb!xc:proclaim `(type . ,form))) ; FIXME: ,@ instead of . , + (sb!xc:proclaim `(type ,@form))) ; FIXME: ,@ instead of . , ((not (info :declaration :recognized kind)) (warn "unrecognized proclamation: ~S" form)))))) (values)) - -;;; Keep the compiler from issuing warnings about SB!C::%%DEFMACRO -;;; when it compiles code which expands into calls to the function -;;; before it's actually compiled the function. -;;; -;;; (This can't be done in defmacro.lisp because PROCLAIM isn't -;;; defined when defmacro.lisp is loaded.) -#+sb-xc-host (sb!xc:proclaim '(ftype function sb!c::%%defmacro)) diff --git a/src/compiler/represent.lisp b/src/compiler/represent.lisp index 0155b2f..e53d400 100644 --- a/src/compiler/represent.lisp +++ b/src/compiler/represent.lisp @@ -354,7 +354,8 @@ (op-tn (tn-ref-tn op)) (*compiler-error-context* op-node)) (cond ((eq (tn-kind op-tn) :constant)) - ((policy op-node (and (<= speed brevity) (<= space brevity)))) + ((policy op-node (and (<= speed inhibit-warnings) + (<= space inhibit-warnings)))) ((member (template-name (vop-info op-vop)) *suppress-note-vops*)) ((null dest-tn) (let* ((op-info (vop-info op-vop)) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index aa6fc0d..7fc4474 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -366,8 +366,10 @@ (eq (global-var-kind leaf) :global-function) (not (null (member (leaf-name leaf) names :test #'equal)))))))) -;;; If Cont is a constant continuation, the return the constant value. If -;;; it is null, then return default, otherwise quietly GIVE-UP. +;;; If CONT is a constant continuation, the return the constant value. +;;; If it is null, then return default, otherwise quietly give up the +;;; IR1 transform. +;;; ;;; ### Probably should take an ARG and flame using the NAME. (defun constant-value-or-lose (cont &optional default) (declare (type (or continuation null) cont)) @@ -378,10 +380,10 @@ (give-up-ir1-transform)))) #| -;;; This is a frob whose job it is to make it easier to pass around the -;;; arguments to IR1 transforms. It bundles together the name of the argument -;;; (which should be referenced in any expansion), and the continuation for -;;; that argument (or NIL if unsupplied.) +;;; This is a frob whose job it is to make it easier to pass around +;;; the arguments to IR1 transforms. It bundles together the name of +;;; the argument (which should be referenced in any expansion), and +;;; the continuation for that argument (or NIL if unsupplied.) (defstruct (arg (:constructor %make-arg (name cont))) (name nil :type symbol) (cont nil :type (or continuation null))) @@ -539,7 +541,8 @@ ,body)) ((not (csubtypep (continuation-type fun-cont) (specifier-type 'function))) - (when (policy *compiler-error-context* (> speed brevity)) + (when (policy *compiler-error-context* + (> speed inhibit-warnings)) (compiler-note "~S may not be a function, so must coerce at run-time." n-fun)) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 6365cf1..148e700 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3262,7 +3262,8 @@ ((= nargs 1) `(progn ,@args t)) ((= nargs 2) `(if (,predicate ,(first args) ,(second args)) nil t)) - ((not (policy nil (and (>= speed space) (>= speed cspeed)))) + ((not (policy nil (and (>= speed space) + (>= speed compilation-speed)))) (values nil t)) (t (let ((vars (make-gensym-list nargs))) diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 4efe8e2..a883da0 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -148,9 +148,10 @@ ;;;; TYPEP source transform -;;; Return a form that tests the variable N-Object for being in the binds -;;; specified by Type. Base is the name of the base type, for declaration. We -;;; make safety locally 0 to inhibit any checking of this assertion. +;;; Return a form that tests the variable N-OBJECT for being in the +;;; binds specified by TYPE. BASE is the name of the base type, for +;;; declaration. We make SAFETY locally 0 to inhibit any checking of +;;; this assertion. #!-negative-zero-is-not-zero (defun transform-numeric-bound-test (n-object type base) (declare (type numeric-type type)) @@ -259,7 +260,7 @@ (declare (type hairy-type type)) (let ((spec (hairy-type-specifier type))) (cond ((unknown-type-p type) - (when (policy nil (> speed brevity)) + (when (policy nil (> speed inhibit-warnings)) (compiler-note "can't open-code test of unknown type ~S" (type-specifier type))) `(%typep ,object ',spec)) @@ -272,7 +273,7 @@ `(typep ,n-obj ',x)) (rest spec)))))))))) -;;; Do source transformation for Typep of a known union type. If a +;;; Do source transformation for TYPEP of a known union type. If a ;;; union type contains LIST, then we pull that out and make it into a ;;; single LISTP call. Note that if SYMBOL is in the union, then LIST ;;; will be a subtype even without there being any (member NIL). We diff --git a/src/compiler/vop.lisp b/src/compiler/vop.lisp index b4316cc..7fc2f6c 100644 --- a/src/compiler/vop.lisp +++ b/src/compiler/vop.lisp @@ -34,20 +34,21 @@ ;;;; PRIMITIVE-TYPEs -;;; The primitive type is used to represent the aspects of type interesting -;;; to the VM. Selection of IR2 translation templates is done on the basis of -;;; the primitive types of the operands, and the primitive type of a value -;;; is used to constrain the possible representations of that value. +;;; The primitive type is used to represent the aspects of type +;;; interesting to the VM. Selection of IR2 translation templates is +;;; done on the basis of the primitive types of the operands, and the +;;; primitive type of a value is used to constrain the possible +;;; representations of that value. (defstruct primitive-type - ;; The name of this primitive-type. + ;; the name of this PRIMITIVE-TYPE (name nil :type symbol) - ;; A list the SC numbers for all the SCs that a TN of this type can be - ;; allocated in. + ;; a list of the SC numbers for all the SCs that a TN of this type + ;; can be allocated in (scs nil :type list) - ;; The Lisp type equivalent to this type. If this type could never be - ;; returned by Primitive-Type, then this is the NIL (or empty) type. + ;; the Lisp type equivalent to this type. If this type could never be + ;; returned by PRIMITIVE-TYPE, then this is the NIL (or empty) type (type (required-argument) :type ctype) - ;; The template used to check that an object is of this type. This is a + ;; the template used to check that an object is of this type. This is a ;; template of one argument and one result, both of primitive-type T. If ;; the argument is of the correct type, then it is delivered into the ;; result. If the type is incorrect, then an error is signalled. @@ -59,21 +60,22 @@ ;;;; IR1 annotations used for IR2 conversion ;;; Block-Info -;;; Holds the IR2-Block structure. If there are overflow blocks, then this -;;; points to the first IR2-Block. The Block-Info of the dummy component -;;; head and tail are dummy IR2 blocks that begin and end the emission order -;;; thread. +;;; Holds the IR2-Block structure. If there are overflow blocks, +;;; then this points to the first IR2-Block. The Block-Info of the +;;; dummy component head and tail are dummy IR2 blocks that begin +;;; and end the emission order thread. ;;; ;;; Component-Info ;;; Holds the IR2-Component structure. ;;; ;;; Continuation-Info -;;; Holds the IR2-Continuation structure. Continuations whose values aren't -;;; used won't have any. +;;; Holds the IR2-Continuation structure. Continuations whose +;;; values aren't used won't have any. ;;; ;;; Cleanup-Info -;;; If non-null, then a TN in which the affected dynamic environment pointer -;;; should be saved after the binding is instantiated. +;;; If non-null, then a TN in which the affected dynamic +;;; environment pointer should be saved after the binding is +;;; instantiated. ;;; ;;; Environment-Info ;;; Holds the IR2-Environment structure. @@ -85,9 +87,10 @@ ;;; Holds the IR2-NLX-Info structure. ;;; ;;; Leaf-Info -;;; If a non-set lexical variable, the TN that holds the value in the home -;;; environment. If a constant, then the corresponding constant TN. -;;; If an XEP lambda, then the corresponding Entry-Info structure. +;;; If a non-set lexical variable, the TN that holds the value in +;;; the home environment. If a constant, then the corresponding +;;; constant TN. If an XEP lambda, then the corresponding +;;; Entry-Info structure. ;;; ;;; Basic-Combination-Info ;;; The template chosen by LTN, or @@ -99,70 +102,74 @@ ;;; After LTN analysis, this is true only in combination nodes that are ;;; truly tail recursive. -;;; The IR2-Block structure holds information about a block that is used during -;;; and after IR2 conversion. It is stored in the Block-Info slot for the -;;; associated block. +;;; An IR2-BLOCK holds information about a block that is used during +;;; and after IR2 conversion. It is stored in the BLOCK-INFO slot for +;;; the associated block. (defstruct (ir2-block (:include block-annotation) (:constructor make-ir2-block (block))) - ;; The IR2-Block's number, which differs from Block's Block-Number if any - ;; blocks are split. This is assigned by lifetime analysis. + ;; the IR2-Block's number, which differs from Block's Block-Number + ;; if any blocks are split. This is assigned by lifetime analysis. (number nil :type (or index null)) - ;; Information about unknown-values continuations that is used by stack - ;; analysis to do stack simulation. A unknown-values continuation is Pushed - ;; if its Dest is in another block. Similarly, a continuation is Popped if - ;; its Dest is in this block but has its uses elsewhere. The continuations - ;; are in the order that are pushed/popped in the block. Note that the args - ;; to a single MV-Combination appear reversed in Popped, since we must - ;; effectively pop the last argument first. All pops must come before all - ;; pushes (although internal MV uses may be interleaved.) Popped is computed - ;; by LTN, and Pushed is computed by stack analysis. + ;; information about unknown-values continuations that is used by + ;; stack analysis to do stack simulation. An UNKNOWN-VALUES + ;; continuation is PUSHED if its DEST is in another block. + ;; Similarly, a continuation is POPPED if its DEST is in this block + ;; but has its uses elsewhere. The continuations are in the order + ;; that are pushed/popped in the block. Note that the args to a + ;; single MV-Combination appear reversed in POPPED, since we must + ;; effectively pop the last argument first. All pops must come + ;; before all pushes (although internal MV uses may be interleaved.) + ;; POPPED is computed by LTN, and PUSHED is computed by stack + ;; analysis. (pushed () :type list) (popped () :type list) - ;; The result of stack analysis: lists of all the unknown-values + ;; the result of stack analysis: lists of all the unknown-values ;; continuations on the stack at the block start and end, topmost ;; continuation first. (start-stack () :type list) (end-stack () :type list) - ;; The first and last VOP in this block. If there are none, both slots are - ;; null. + ;; the first and last VOP in this block. If there are none, both + ;; slots are null. (start-vop nil :type (or vop null)) (last-vop nil :type (or vop null)) - ;; Number of local TNs actually allocated. + ;; the number of local TNs actually allocated (local-tn-count 0 :type local-tn-count) - ;; A vector that maps local TN numbers to TNs. Some entries may be NIL, - ;; indicating that that number is unused. (This allows us to delete local - ;; conflict information without compressing the LTN numbers.) - ;; - ;; If an entry is :More, then this block contains only a single VOP. This - ;; VOP has so many more arguments and/or results that they cannot all be - ;; assigned distinct LTN numbers. In this case, we assign all the more args - ;; one LTN number, and all the more results another LTN number. We can do - ;; this, since more operands are referenced simultaneously as far as conflict - ;; analysis is concerned. Note that all these :More TNs will be global TNs. + ;; a vector that maps local TN numbers to TNs. Some entries may be + ;; NIL, indicating that that number is unused. (This allows us to + ;; delete local conflict information without compressing the LTN + ;; numbers.) + ;; + ;; If an entry is :MORE, then this block contains only a single VOP. + ;; This VOP has so many more arguments and/or results that they + ;; cannot all be assigned distinct LTN numbers. In this case, we + ;; assign all the more args one LTN number, and all the more results + ;; another LTN number. We can do this, since more operands are + ;; referenced simultaneously as far as conflict analysis is + ;; concerned. Note that all these :More TNs will be global TNs. (local-tns (make-array local-tn-limit) :type local-tn-vector) - ;; Bit-vectors used during lifetime analysis to keep track of references to - ;; local TNs. When indexed by the LTN number, the index for a TN is non-zero - ;; in Written if it is ever written in the block, and in Live-Out if - ;; the first reference is a read. + ;; Bit-vectors used during lifetime analysis to keep track of + ;; references to local TNs. When indexed by the LTN number, the + ;; index for a TN is non-zero in Written if it is ever written in + ;; the block, and in Live-Out if the first reference is a read. (written (make-array local-tn-limit :element-type 'bit :initial-element 0) :type local-tn-bit-vector) (live-out (make-array local-tn-limit :element-type 'bit) :type local-tn-bit-vector) - ;; Similar to the above, but is updated by lifetime flow analysis to have a 1 - ;; for LTN numbers of TNs live at the end of the block. This takes into - ;; account all TNs that aren't :Live. + ;; This is similar to the above, but is updated by lifetime flow + ;; analysis to have a 1 for LTN numbers of TNs live at the end of + ;; the block. This takes into account all TNs that aren't :Live. (live-in (make-array local-tn-limit :element-type 'bit :initial-element 0) :type local-tn-bit-vector) - ;; A thread running through the global-conflicts structures for this block, - ;; sorted by TN number. + ;; a thread running through the global-conflicts structures for this + ;; block, sorted by TN number (global-tns nil :type (or global-conflicts null)) - ;; The assembler label that points to the beginning of the code for this - ;; block. Null when we haven't assigned a label yet. + ;; the assembler label that points to the beginning of the code for + ;; this block, or NIL when we haven't assigned a label yet (%label nil) - ;; List of Location-Info structures describing all the interesting (to the - ;; debugger) locations in this block. + ;; list of Location-Info structures describing all the interesting + ;; (to the debugger) locations in this block (locations nil :type list)) (defprinter (ir2-block) @@ -173,38 +180,41 @@ (local-tn-count :test (not (zerop local-tn-count))) (%label :test %label)) -;;; The IR2-Continuation structure is used to annotate continuations that are -;;; used as a function result continuation or that receive MVs. +;;; An IR2-Continuation structure is used to annotate continuations +;;; that are used as a function result continuation or that receive MVs. (defstruct (ir2-continuation (:constructor make-ir2-continuation (primitive-type))) - ;; If this is :Delayed, then this is a single value continuation for which - ;; the evaluation of the use is to be postponed until the evaluation of - ;; destination. This can be done for ref nodes or predicates whose - ;; destination is an IF. + ;; If this is :DELAYED, then this is a single value continuation for + ;; which the evaluation of the use is to be postponed until the + ;; evaluation of destination. This can be done for ref nodes or + ;; predicates whose destination is an IF. ;; - ;; If this is :Fixed, then this continuation has a fixed number of values, - ;; with the TNs in Locs. + ;; If this is :FIXED, then this continuation has a fixed number of + ;; values, with the TNs in LOCS. ;; - ;; If this is :Unknown, then this is an unknown-values continuation, using - ;; the passing locations in Locs. + ;; If this is :UNKNOWN, then this is an unknown-values continuation, + ;; using the passing locations in LOCS. ;; - ;; If this is :Unused, then this continuation should never actually be used - ;; as the destination of a value: it is only used tail-recursively. + ;; If this is :UNUSED, then this continuation should never actually + ;; be used as the destination of a value: it is only used + ;; tail-recursively. (kind :fixed :type (member :delayed :fixed :unknown :unused)) - ;; The primitive-type of the first value of this continuation. This is - ;; primarily for internal use during LTN, but it also records the type - ;; restriction on delayed references. In multiple-value contexts, this is - ;; null to indicate that it is meaningless. This is always (primitive-type - ;; (continuation-type cont)), which may be more restrictive than the - ;; tn-primitive-type of the value TN. This is becase the value TN must hold - ;; any possible type that could be computed (before type checking.) + ;; The primitive-type of the first value of this continuation. This + ;; is primarily for internal use during LTN, but it also records the + ;; type restriction on delayed references. In multiple-value + ;; contexts, this is null to indicate that it is meaningless. This + ;; is always (primitive-type (continuation-type cont)), which may be + ;; more restrictive than the tn-primitive-type of the value TN. This + ;; is becase the value TN must hold any possible type that could be + ;; computed (before type checking.) (primitive-type nil :type (or primitive-type null)) - ;; Locations used to hold the values of the continuation. If the number - ;; of values if fixed, then there is one TN per value. If the number of - ;; values is unknown, then this is a two-list of TNs holding the start of the - ;; values glob and the number of values. Note that since type checking is - ;; the responsibility of the values receiver, these TNs primitive type is - ;; only based on the proven type information. + ;; Locations used to hold the values of the continuation. If the + ;; number of values if fixed, then there is one TN per value. If the + ;; number of values is unknown, then this is a two-list of TNs + ;; holding the start of the values glob and the number of values. + ;; Note that since type checking is the responsibility of the values + ;; receiver, these TNs primitive type is only based on the proven + ;; type information. (locs nil :type list)) (defprinter (ir2-continuation) @@ -212,141 +222,145 @@ primitive-type locs) -;;; The IR2-Component serves mostly to accumulate non-code information about -;;; the component being compiled. +;;; The IR2-Component serves mostly to accumulate non-code information +;;; about the component being compiled. (defstruct ir2-component - ;; The counter used to allocate global TN numbers. + ;; the counter used to allocate global TN numbers (global-tn-counter 0 :type index) - ;; Normal-TNs is the head of the list of all the normal TNs that need to be - ;; packed, linked through the Next slot. We place TNs on this list when we - ;; allocate them so that Pack can find them. + ;; NORMAL-TNS is the head of the list of all the normal TNs that + ;; need to be packed, linked through the Next slot. We place TNs on + ;; this list when we allocate them so that Pack can find them. ;; - ;; Restricted-TNs are TNs that must be packed within a finite SC. We pack - ;; these TNs first to ensure that the restrictions will be satisfied (if - ;; possible). + ;; RESTRICTED-TNS are TNs that must be packed within a finite SC. We + ;; pack these TNs first to ensure that the restrictions will be + ;; satisfied (if possible). ;; - ;; Wired-TNs are TNs that must be packed at a specific location. The SC - ;; and Offset are already filled in. + ;; WIRED-TNs are TNs that must be packed at a specific location. The + ;; SC and OFFSET are already filled in. ;; - ;; Constant-TNs are non-packed TNs that represent constants. :Constant TNs - ;; may eventually be converted to :Cached-Constant normal TNs. + ;; CONSTANT-TNs are non-packed TNs that represent constants. + ;; :CONSTANT TNs may eventually be converted to :CACHED-CONSTANT + ;; normal TNs. (normal-tns nil :type (or tn null)) (restricted-tns nil :type (or tn null)) (wired-tns nil :type (or tn null)) (constant-tns nil :type (or tn null)) - ;; A list of all the :COMPONENT TNs (live throughout the component.) These - ;; TNs will also appear in the {NORMAL,RESTRICTED,WIRED} TNs as appropriate - ;; to their location. + ;; a list of all the :COMPONENT TNs (live throughout the component). + ;; These TNs will also appear in the {NORMAL,RESTRICTED,WIRED} TNs + ;; as appropriate to their location. (component-tns () :type list) ;; If this component has a NFP, then this is it. (nfp nil :type (or tn null)) - ;; A list of the explicitly specified save TNs (kind :SPECIFIED-SAVE). These - ;; TNs will also appear in the {NORMAL,RESTRICTED,WIRED} TNs as appropriate - ;; to their location. + ;; a list of the explicitly specified save TNs (kind + ;; :SPECIFIED-SAVE). These TNs will also appear in the + ;; {NORMAL,RESTRICTED,WIRED} TNs as appropriate to their location. (specified-save-tns () :type list) - ;; Values-Receivers is a list of all the blocks whose ir2-block has a - ;; non-null value for Popped. This slot is initialized by LTN-Analyze as an - ;; input to Stack-Analyze. + ;; a list of all the blocks whose IR2-BLOCK has a non-null value for + ;; POPPED. This slot is initialized by LTN-ANALYZE as an input to + ;; STACK-ANALYZE. (values-receivers nil :type list) - ;; An adjustable vector that records all the constants in the constant pool. - ;; A non-immediate :Constant TN with offset 0 refers to the constant in - ;; element 0, etc. Normal constants are represented by the placing the - ;; Constant leaf in this vector. A load-time constant is distinguished by - ;; being a cons (Kind . What). Kind is a keyword indicating how the constant - ;; is computed, and What is some context. + ;; an adjustable vector that records all the constants in the + ;; constant pool. A non-immediate :CONSTANT TN with offset 0 refers + ;; to the constant in element 0, etc. Normal constants are + ;; represented by the placing the CONSTANT leaf in this vector. A + ;; load-time constant is distinguished by being a cons (KIND . + ;; WHAT). KIND is a keyword indicating how the constant is computed, + ;; and WHAT is some context. ;; ;; These load-time constants are recognized: ;; ;; (:entry . ) - ;; Is replaced by the code pointer for the specified function. This is - ;; how compiled code (including DEFUN) gets its hands on a function. - ;; is the XEP lambda for the called function; its Leaf-Info - ;; should be an Entry-Info structure. + ;; Is replaced by the code pointer for the specified function. + ;; This is how compiled code (including DEFUN) gets its hands on + ;; a function. is the XEP lambda for the called + ;; function; its LEAF-INFO should be an ENTRY-INFO structure. ;; ;; (:label .