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*.
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:
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")
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))
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
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.
: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"
"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"
"!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"
#!+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))
;; 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?
(/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)
;; 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*))
`(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)
(cond ((policy (continuation-dest cont)
(and (<= speed safety)
(<= space safety)
- (<= cspeed safety)))
+ (<= compilation-speed safety)))
type)
(t
(let ((min-cost (type-test-cost type))
(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*))
(: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)))))
(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))
(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)
(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))
\f
;;;; 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*))
\f
;;; possible values for the INLINE-ness of a function.
(deftype inlinep ()
;; 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)
(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
(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*
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)
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)))
(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
`(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)
(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)
\f
;;;; 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.
;;;
;;; 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
(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)
(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)))
;;; 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))
(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)))
(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)))
\f
;;;; flow/DFO/component hackery
(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."
;;; 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))
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.
;;;
;;; 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))
(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))))
;;; 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)
(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))
(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))))
;;; 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))
(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))
(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)))
(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)))
(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))
;;; 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
(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))))
(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)))
;; 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
\f
;;;; 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
;;;
;;; 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)))
\f
\f
;;;; 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)
;;;
;;; 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))
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"))))
\f
;;;; 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))
(defmacro position-or-lose (&rest args)
`(or (position ,@args)
- (error "Shouldn't happen?")))
+ (error "shouldn't happen?")))
(entry-analyze component)
(ir2-convert component)
- (when (policy nil (>= speed cspeed))
+ (when (policy nil (>= speed compilation-speed))
(maybe-mumble "copy ")
(copy-propagate component))
(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)
(*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)
(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)
(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
(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)
;;; 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)
(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))
(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))
(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))
(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)))
,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))
((= 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)))
\f
;;;; 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))
(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))
`(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
\f
;;;; 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.
;;;; 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.
;;; 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
;;; 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)
(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)
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 . <function>)
- ;; Is replaced by the code pointer for the specified function. This is
- ;; how compiled code (including DEFUN) gets its hands on a function.
- ;; <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. <function> is the XEP lambda for the called
+ ;; function; its LEAF-INFO should be an ENTRY-INFO structure.
;;
;; (:label . <label>)
- ;; Is replaced with the byte offset of that label from the start of the
- ;; code vector (including the header length.)
+ ;; Is replaced with the byte offset of that label from the start
+ ;; of the code vector (including the header length.)
;;
- ;; A null entry in this vector is a placeholder for implementation overhead
- ;; that is eventually stuffed in somehow.
+ ;; A null entry in this vector is a placeholder for implementation
+ ;; overhead that is eventually stuffed in somehow.
(constants (make-array 10 :fill-pointer 0 :adjustable t) :type vector)
- ;; Some kind of info about the component's run-time representation. This is
- ;; filled in by the VM supplied Select-Component-Format function.
+ ;; some kind of info about the component's run-time representation.
+ ;; This is filled in by the VM supplied Select-Component-Format function.
format
- ;; A list of the Entry-Info structures describing all of the entries into
- ;; this component. Filled in by entry analysis.
+ ;; a list of the ENTRY-INFO structures describing all of the entries
+ ;; into this component. Filled in by entry analysis.
(entries nil :type list)
;; Head of the list of :ALIAS TNs in this component, threaded by TN-NEXT.
(alias-tns nil :type (or tn null))
- ;; Spilled-VOPs is a hashtable translating from "interesting" VOPs to a list
- ;; of the TNs spilled at that VOP. This is used when computing debug info so
- ;; that we don't consider the TN's value to be valid when it is in fact
- ;; somewhere else. Spilled-TNs has T for every "interesting" TN that is ever
- ;; spilled, providing a representation that is more convenient some places.
+ ;; SPILLED-VOPS is a hashtable translating from "interesting" VOPs
+ ;; to a list of the TNs spilled at that VOP. This is used when
+ ;; computing debug info so that we don't consider the TN's value to
+ ;; be valid when it is in fact somewhere else. SPILLED-TNS has T for
+ ;; every "interesting" TN that is ever spilled, providing a
+ ;; representation that is more convenient some places.
(spilled-vops (make-hash-table :test 'eq) :type hash-table)
(spilled-tns (make-hash-table :test 'eq) :type hash-table)
- ;; Dynamic vop count info. This is needed by both ir2-convert and
+ ;; dynamic vop count info. This is needed by both ir2-convert and
;; setup-dynamic-count-info. (But only if we are generating code to
;; collect dynamic statistics.)
#!+sb-dyncount
(dyncount-info nil :type (or null dyncount-info)))
-;;; The Entry-Info structure condenses all the information that the dumper
-;;; needs to create each XEP's function entry data structure. The Entry-Info
-;;; structures are somtimes created before they are initialized, since ir2
-;;; conversion may need to compile a forward reference. In this case
-;;; the slots aren't actually initialized until entry analysis runs.
+;;; An ENTRY-INFO condenses all the information that the dumper needs
+;;; to create each XEP's function entry data structure. ENTRY-INFO
+;;; structures are somtimes created before they are initialized, since
+;;; IR2 conversion may need to compile a forward reference. In this
+;;; case the slots aren't actually initialized until entry analysis runs.
(defstruct entry-info
- ;; True if this function has a non-null closure environment.
+ ;; true if this function has a non-null closure environment
(closure-p nil :type boolean)
- ;; A label pointing to the entry vector for this function. Null until
- ;; ENTRY-ANALYZE runs.
+ ;; a label pointing to the entry vector for this function, or NIL
+ ;; before ENTRY-ANALYZE runs
(offset nil :type (or label null))
- ;; If this function was defined using DEFUN, then this is the name of the
- ;; function, a symbol or (SETF <symbol>). Otherwise, this is some string
- ;; that is intended to be informative.
+ ;; If this function was defined using DEFUN, then this is the name
+ ;; of the function, a symbol or (SETF <symbol>). Otherwise, this is
+ ;; some string that is intended to be informative.
(name "<not computed>" :type (or simple-string list symbol))
- ;; A string representing the argument list that the function was defined
- ;; with.
+ ;; a string representing the argument list that the function was
+ ;; defined with
(arguments nil :type (or simple-string null))
- ;; A function type specifier representing the arguments and results of this
- ;; function.
+ ;; a function type specifier representing the arguments and results
+ ;; of this function
(type 'function :type (or list (member function))))
-;;; An IR2-ENVIRONMENT is used to annotate non-LET lambdas with their passing
-;;; locations. It is stored in the Environment-Info.
+;;; An IR2-ENVIRONMENT is used to annotate non-LET lambdas with their
+;;; passing locations. It is stored in the Environment-Info.
(defstruct ir2-environment
- ;; The TNs that hold the passed environment within the function. This is an
- ;; alist translating from the NLX-Info or lambda-var to the TN that holds
- ;; the corresponding value within this function. This list is in the same
- ;; order as the ENVIRONMENT-CLOSURE.
+ ;; the TNs that hold the passed environment within the function.
+ ;; This is an alist translating from the NLX-Info or lambda-var to
+ ;; the TN that holds the corresponding value within this function.
+ ;; This list is in the same order as the ENVIRONMENT-CLOSURE.
(environment nil :type list)
- ;; The TNs that hold the Old-Fp and Return-PC within the function. We
- ;; always save these so that the debugger can do a backtrace, even if the
- ;; function has no return (and thus never uses them). Null only temporarily.
+ ;; the TNs that hold the OLD-FP and RETURN-PC within the function.
+ ;; We always save these so that the debugger can do a backtrace,
+ ;; even if the function has no return (and thus never uses them).
+ ;; Null only temporarily.
(old-fp nil :type (or tn null))
(return-pc nil :type (or tn null))
;; The passing location for the Return-PC. The return PC is treated
- ;; differently from the other arguments, since in some implementations we may
- ;; use a call instruction that requires the return PC to be passed in a
- ;; particular place.
+ ;; differently from the other arguments, since in some
+ ;; implementations we may use a call instruction that requires the
+ ;; return PC to be passed in a particular place.
(return-pc-pass (required-argument) :type tn)
- ;; True if this function has a frame on the number stack. This is set by
- ;; representation selection whenever it is possible that some function in
- ;; our tail set will make use of the number stack.
+ ;; True if this function has a frame on the number stack. This is
+ ;; set by representation selection whenever it is possible that some
+ ;; function in our tail set will make use of the number stack.
(number-stack-p nil :type boolean)
- ;; A list of all the :Environment TNs live in this environment.
+ ;; a list of all the :ENVIRONMENT TNs live in this environment
(live-tns nil :type list)
- ;; A list of all the :Debug-Environment TNs live in this environment.
+ ;; a list of all the :DEBUG-ENVIRONMENT TNs live in this environment
(debug-live-tns nil :type list)
- ;; A label that marks the start of elsewhere code for this function. Null
- ;; until this label is assigned by codegen. Used for maintaining the debug
- ;; source map.
+ ;; a label that marks the start of elsewhere code for this function.
+ ;; Null until this label is assigned by codegen. Used for
+ ;; maintaining the debug source map.
(elsewhere-start nil :type (or label null))
- ;; A label that marks the first location in this function at which the
- ;; environment is properly initialized, i.e. arguments moved from their
- ;; passing locations, etc. This is the start of the function as far as the
- ;; debugger is concerned.
+ ;; a label that marks the first location in this function at which
+ ;; the environment is properly initialized, i.e. arguments moved
+ ;; from their passing locations, etc. This is the start of the
+ ;; function as far as the debugger is concerned.
(environment-start nil :type (or label null)))
(defprinter (ir2-environment)
environment
return-pc
return-pc-pass)
-;;; The RETURN-INFO structure is used by GTN to represent the return
-;;; strategy and locations for all the functions in a given TAIL-SET.
-;;; It is stored in the TAIL-SET-INFO.
+;;; A RETURN-INFO is used by GTN to represent the return strategy and
+;;; locations for all the functions in a given TAIL-SET. It is stored
+;;; in the TAIL-SET-INFO.
(defstruct return-info
;; The return convention used:
- ;; -- If :Unknown, we use the standard return convention.
- ;; -- If :Fixed, we use the known-values convention.
+ ;; -- If :UNKNOWN, we use the standard return convention.
+ ;; -- If :FIXED, we use the known-values convention.
(kind (required-argument) :type (member :fixed :unknown))
- ;; The number of values returned, or :Unknown if we don't know. Count may be
- ;; known when Kind is :Unknown, since we may choose the standard return
- ;; convention for other reasons.
+ ;; the number of values returned, or :UNKNOWN if we don't know.
+ ;; COUNT may be known when KIND is :UNKNOWN, since we may choose the
+ ;; standard return convention for other reasons.
(count (required-argument) :type (or index (member :unknown)))
- ;; If count isn't :Unknown, then this is a list of the primitive-types of
- ;; each value.
+ ;; If count isn't :UNKNOWN, then this is a list of the
+ ;; primitive-types of each value.
(types () :type list)
- ;; If kind is :Fixed, then this is the list of the TNs that we return the
- ;; values in.
+ ;; If kind is :FIXED, then this is the list of the TNs that we
+ ;; return the values in.
(locations () :type list))
(defprinter (return-info)
kind
`(declare
;; FIXME: Are these (DECLARE (SB-PCL::CLASS FOO BAR))
;; declarations used for anything any more?
+ ;; WHN 2000-12-21: I think not, commented 'em out to see..
,@(remove nil
(mapcar (lambda (a s) (and (symbolp s)
(neq s 't)
projects / sbcl.git / commitdiff