;; rid of FDEFINITIONs entirely later.
"*SETF-FDEFINITION-HOOK*"
- ;; useful but non-standard user-level functions..
+ ;; non-standard but widely useful user-level functions..
"ASSQ" "DELQ" "MEMQ"
"%FIND-PACKAGE-OR-LOSE" "FIND-UNDELETED-PACKAGE-OR-LOSE"
"SANE-PACKAGE"
"CIRCULAR-LIST-P"
- ;; ..and macros
+ ;; ..and macros..
"COLLECT"
"DO-ANONYMOUS" "DOHASH" "DOVECTOR"
"ITERATE"
"LETF" "LETF*"
"ONCE-ONLY"
"DEFENUM"
+ "DEFPRINTER"
"DEF!MACRO" "DEF!METHOD" "DEF!STRUCT" "DEF!TYPE"
+ ;; ..and DEFTYPEs..
+ "INDEX"
+
+ ;; ..and type predicates
+ "INSTANCEP"
+ "DOUBLE-FLOATP"
+ "LOGICAL-PATHNAME-P"
+ "LONG-FLOATP"
+ "SHORT-FLOATP"
+ "SINGLE-FLOATP"
+
;; encapsulation
"ARGUMENT-LIST"
"BASIC-DEFINITION"
"BELL-CHAR-CODE" "ESCAPE-CHAR-CODE" "FORM-FEED-CHAR-CODE"
"RETURN-CHAR-CODE" "RUBOUT-CHAR-CODE" "TAB-CHAR-CODE"
- ;; handy user-level/basically-portable DEFTYPEs
- "INDEX"
-
- ;; nonstandard type predicates
- "INSTANCEP"
- "DOUBLE-FLOATP"
- "LOGICAL-PATHNAME-P"
- "LONG-FLOATP"
- "SHORT-FLOATP"
- "SINGLE-FLOATP"
-
;; symbol-hacking idioms
"CONCAT-PNAMES" "KEYWORDICATE" "SYMBOLICATE"
;; FIXME: Maybe this isn't used any more? And if it is,
;; it probably needs a better name, since SPECIAL things
- ;; are so obnoxious in Common Lisp.
+ ;; are such a nice source of sneaky bugs.
"E"
;; various internal defaults
(coerce (cdr (res)) 'simple-vector))))
-;;; This variable maps minimal debug-info function maps to an unpacked
-;;; version thereof.
+;;; a map from minimal DEBUG-INFO function maps to unpacked
+;;; versions thereof
(defvar *uncompacted-function-maps* (make-hash-table :test 'eq))
-;;; Return a function-map for a given compiled-debug-info object. If
+;;; Return a FUNCTION-MAP for a given COMPILED-DEBUG-info object. If
;;; the info is minimal, and has not been parsed, then parse it.
;;;
-;;; FIXME: Now that we no longer use the minimal-debug-function
+;;; FIXME: Now that we no longer use the MINIMAL-DEBUG-FUNCTION
;;; representation, calls to this function can be replaced by calls to
;;; the bare COMPILED-DEBUG-INFO-FUNCTION-MAP slot accessor function,
;;; and this function and everything it calls become dead code which
\f
;;;; CODE-LOCATIONs
-;;; If we're sure of whether code-location is known, return t or nil.
-;;; If we're :unsure, then try to fill in the code-location's slots.
+;;; If we're sure of whether code-location is known, return T or NIL.
+;;; If we're :UNSURE, then try to fill in the code-location's slots.
;;; This determines whether there is any debug-block information, and
;;; if code-location is known.
;;;
;;; ??? IF this conses closures every time it's called, then break off the
-;;; :unsure part to get the HANDLER-CASE into another function.
+;;; :UNSURE part to get the HANDLER-CASE into another function.
(defun code-location-unknown-p (basic-code-location)
- #!+sb-doc
- "Returns whether basic-code-location is unknown. It returns nil when the
- code-location is known."
(ecase (code-location-%unknown-p basic-code-location)
((t) t)
((nil) nil)
(handler-case (not (fill-in-code-location basic-code-location))
(no-debug-blocks () t))))))
+;;; Return the DEBUG-BLOCK containing code-location if it is available.
+;;; Some debug policies inhibit debug-block information, and if none
+;;; is available, then this signals a NO-DEBUG-BLOCKS condition.
(defun code-location-debug-block (basic-code-location)
- #!+sb-doc
- "Returns the debug-block containing code-location if it is available. Some
- debug policies inhibit debug-block information, and if none is available,
- then this signals a no-debug-blocks condition."
(let ((block (code-location-%debug-block basic-code-location)))
(if (eq block :unparsed)
(etypecase basic-code-location
(interpreted-code-location-ir1-node basic-code-location))))))
block)))
-;;; This stores and returns BASIC-CODE-LOCATION's debug-block. It
-;;; determines the correct one using the code-location's pc. This uses
+;;; Store and return BASIC-CODE-LOCATION's debug-block. We determines
+;;; the correct one using the code-location's pc. We use
;;; DEBUG-FUNCTION-DEBUG-BLOCKS to return the cached block information
-;;; or signal a 'no-debug-blocks condition. The blocks are sorted by
+;;; or signal a NO-DEBUG-BLOCKS condition. The blocks are sorted by
;;; their first code-location's pc, in ascending order. Therefore, as
;;; soon as we find a block that starts with a pc greater than
;;; basic-code-location's pc, we know the previous block contains the
(let ((live-set (compiled-code-location-%live-set code-location)))
(cond ((eq live-set :unparsed)
(unless (fill-in-code-location code-location)
- ;; This check should be unnecessary. We're missing debug info
- ;; the compiler should have dumped.
+ ;; This check should be unnecessary. We're missing
+ ;; debug info the compiler should have dumped.
;;
;; FIXME: This error and comment happen over and over again.
;; Make them a shared function.
(compiled-code-location-%live-set code-location))
(t live-set)))))
+;;; true if OBJ1 and OBJ2 are the same place in the code
(defun code-location= (obj1 obj2)
- #!+sb-doc
- "Returns whether obj1 and obj2 are the same place in the code."
(etypecase obj1
(compiled-code-location
(etypecase obj2
(= (compiled-code-location-pc obj1)
(compiled-code-location-pc obj2)))
-;;; This fills in CODE-LOCATION's :unparsed slots. It returns t or nil
+;;; Fill in CODE-LOCATION's :UNPARSED slots, returning T or NIL
;;; depending on whether the code-location was known in its
;;; debug-function's debug-block information. This may signal a
;;; NO-DEBUG-BLOCKS condition due to DEBUG-FUNCTION-DEBUG-BLOCKS, and
(symbolp (cadr name))
(null (cddr name)))))
-;;; Given a function name, return the name for the BLOCK which encloses its
-;;; body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET).
+;;; Given a function name, return the name for the BLOCK which
+;;; encloses its body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET).
(declaim (ftype (function ((or symbol cons)) symbol) function-name-block-name))
(defun function-name-block-name (function-name)
(cond ((symbolp function-name)
;; value.)
))
\f
+;;;; DEFPRINTER
+
+;;; These functions are called by the expansion of the DEFPRINTER
+;;; macro to do the actual printing.
+(declaim (ftype (function (symbol t stream &optional t) (values))
+ defprinter-prin1 defprinter-princ))
+(defun defprinter-prin1 (name value stream &optional indent)
+ (declare (ignore indent))
+ (defprinter-prinx #'prin1 name value stream))
+(defun defprinter-princ (name value stream &optional indent)
+ (declare (ignore indent))
+ (defprinter-prinx #'princ name value stream))
+(defun defprinter-prinx (prinx name value stream)
+ (declare (type function prinx))
+ (when *print-pretty*
+ (pprint-newline :linear stream))
+ (format stream ":~A " name)
+ (funcall prinx value stream)
+ (values))
+(defun defprinter-print-space (stream)
+ (write-char #\space stream))
+
+;;; Define some kind of reasonable PRINT-OBJECT method for a
+;;; STRUCTURE-OBJECT class.
+;;;
+;;; NAME is the name of the structure class, and CONC-NAME is the same
+;;; as in DEFSTRUCT.
+;;;
+;;; The SLOT-DESCS describe how each slot should be printed. Each
+;;; SLOT-DESC can be a slot name, indicating that the slot should
+;;; simply be printed. A SLOT-DESC may also be a list of a slot name
+;;; and other stuff. The other stuff is composed of keywords followed
+;;; by expressions. The expressions are evaluated with the variable
+;;; which is the slot name bound to the value of the slot. These
+;;; keywords are defined:
+;;;
+;;; :PRIN1 Print the value of the expression instead of the slot value.
+;;; :PRINC Like :PRIN1, only princ the value
+;;; :TEST Only print something if the test is true.
+;;;
+;;; If no printing thing is specified then the slot value is printed
+;;; as if by PRIN1.
+;;;
+;;; The structure being printed is bound to STRUCTURE and the stream
+;;; is bound to STREAM.
+(defmacro defprinter ((name &key (conc-name (concatenate 'simple-string
+ (symbol-name name)
+ "-")))
+ &rest slot-descs)
+ (let ((first? t)
+ maybe-print-space
+ (reversed-prints nil)
+ (stream (gensym "STREAM")))
+ (flet ((sref (slot-name)
+ `(,(symbolicate conc-name slot-name) structure)))
+ (dolist (slot-desc slot-descs)
+ (if first?
+ (setf maybe-print-space nil
+ first? nil)
+ (setf maybe-print-space `(defprinter-print-space ,stream)))
+ (cond ((atom slot-desc)
+ (push maybe-print-space reversed-prints)
+ (push `(defprinter-prin1 ',slot-desc ,(sref slot-desc) ,stream)
+ reversed-prints))
+ (t
+ (let ((sname (first slot-desc))
+ (test t))
+ (collect ((stuff))
+ (do ((option (rest slot-desc) (cddr option)))
+ ((null option)
+ (push `(let ((,sname ,(sref sname)))
+ (when ,test
+ ,maybe-print-space
+ ,@(or (stuff)
+ `((defprinter-prin1
+ ',sname ,sname ,stream)))))
+ reversed-prints))
+ (case (first option)
+ (:prin1
+ (stuff `(defprinter-prin1
+ ',sname ,(second option) ,stream)))
+ (:princ
+ (stuff `(defprinter-princ
+ ',sname ,(second option) ,stream)))
+ (:test (setq test (second option)))
+ (t
+ (error "bad option: ~S" (first option)))))))))))
+ `(def!method print-object ((structure ,name) ,stream)
+ ;; FIXME: should probably be byte-compiled
+ (pprint-logical-block (,stream nil)
+ (print-unreadable-object (structure ,stream :type t)
+ (when *print-pretty*
+ (pprint-indent :block 2 ,stream))
+ ,@(nreverse reversed-prints))))))
+\f
#|
;;; REMOVEME when done testing byte cross-compiler
(defun byte-compiled-foo (x y)
(macrolet ((clone-arg () '(read-arg 1)))
(define-fop (,small-name ,small-code ,pushp) ,@forms))))
-;;; a helper function for reading string values from FASL files: sort of like
-;;; READ-SEQUENCE specialized for files of (UNSIGNED-BYTE 8), with an automatic
-;;; conversion from (UNSIGNED-BYTE 8) into CHARACTER for each element read
+;;; a helper function for reading string values from FASL files: sort
+;;; of like READ-SEQUENCE specialized for files of (UNSIGNED-BYTE 8),
+;;; with an automatic conversion from (UNSIGNED-BYTE 8) into CHARACTER
+;;; for each element read
(declaim (ftype (function (stream simple-string &optional index) (values)) read-string-as-bytes))
(defun read-string-as-bytes (stream string &optional (length (length string)))
(dotimes (i length)
#!+sb-show
(defvar *show-fop-nop4-p* nil)
-;;; CMU CL had a single no-op fop, FOP-NOP, with fop code 0. Since 0 occurs
-;;; disproportionately often in fasl files for other reasons, FOP-NOP is less
-;;; than ideal for writing human-readable patterns into fasl files for
-;;; debugging purposes. There's no shortage of unused fop codes, so we add this
-;;; second NOP, which reads 4 arbitrary bytes and discards them.
+;;; CMU CL had a single no-op fop, FOP-NOP, with fop code 0. Since 0
+;;; occurs disproportionately often in fasl files for other reasons,
+;;; FOP-NOP is less than ideal for writing human-readable patterns
+;;; into fasl files for debugging purposes. There's no shortage of
+;;; unused fop codes, so we add this second NOP, which reads 4
+;;; arbitrary bytes and discards them.
(define-fop (fop-nop4 137 :nope)
(let ((arg (read-arg 4)))
(declare (ignorable arg))
(defmacro-mundanely defconstant (name value &optional documentation)
#!+sb-doc
- "For defining global constants. The DEFCONSTANT says that the value
- is constant and may be compiled into code. If the variable already has
+ "For defining global constants. DEFCONSTANT says that the value is
+ constant and may be compiled into code. If the variable already has
a value, and this is not EQL to the init, the code is not portable
(undefined behavior). The third argument is an optional documentation
string for the variable."
;;; the guts of DEFCONSTANT
(defun sb!c::%defconstant (name value doc)
- (/show "doing %DEFCONSTANT" name value doc)
(unless (symbolp name)
(error "constant name not a symbol: ~S" name))
(about-to-modify name)
(let ((kind (info :variable :kind name)))
(case kind
(:constant
- ;; Note 1: This behavior (discouraging any non-EQL
- ;; modification) is unpopular, but it is specified by ANSI
- ;; (i.e. ANSI says a non-EQL change has undefined
- ;; consequences). If people really want bindings which are
- ;; constant in some sense other than EQL, I suggest either just
- ;; using DEFVAR (which is usually appropriate, despite the
- ;; un-mnemonic name), or defining something like
- ;; SB-INT:DEFCONSTANT-EQX (which is occasionally more
- ;; appropriate). -- WHN 2000-11-03
+ ;; Note: This behavior (discouraging any non-EQL modification)
+ ;; is unpopular, but it is specified by ANSI (i.e. ANSI says a
+ ;; non-EQL change has undefined consequences). If people really
+ ;; want bindings which are constant in some sense other than
+ ;; EQL, I suggest either just using DEFVAR (which is usually
+ ;; appropriate, despite the un-mnemonic name), or defining
+ ;; something like SB-INT:DEFCONSTANT-EQX (which is occasionally
+ ;; more appropriate). -- WHN 2000-11-03
(unless (eql value
(info :variable :constant-value name))
(cerror "Go ahead and change the value."
;;; CLEAR-STATS-FUN clears the statistics.
;;;
;;; (The reason for implementing this as coupled closures, with the
-;;; counts built into the lexical environment, is that we hopes this
+;;; counts built into the lexical environment, is that we hope this
;;; will minimize profiling overhead.)
(defun profile-encapsulation-lambdas (encapsulated-fun)
(declare (type function encapsulated-fun))
\f
;;; interfaces
-;;; A symbol names a function, a string names all the functions named
-;;; by symbols in the named package.
+;;; A symbol or (SETF FOO) list names a function, a string names all
+;;; the functions named by symbols in the named package.
(defun mapc-on-named-functions (function names)
(dolist (name names)
(etypecase name
(symbol (funcall function name))
+ (list
+ ;; We call this just for the side effect of checking that
+ ;; NAME is a legal function name:
+ (function-name-block-name name)
+ ;; Then we map onto it.
+ (funcall function name))
(string (let ((package (find-undeleted-package-or-lose name)))
(do-symbols (symbol package)
(when (eq (symbol-package symbol) package)
(alien-function-type-result-type type)))))
(defoptimizer (%alien-funcall ltn-annotate)
- ((function type &rest args) node policy)
+ ((function type &rest args) node ltn-policy)
(setf (basic-combination-info node) :funny)
(setf (node-tail-p node) nil)
- (annotate-ordinary-continuation function policy)
+ (annotate-ordinary-continuation function ltn-policy)
(dolist (arg args)
- (annotate-ordinary-continuation arg policy)))
+ (annotate-ordinary-continuation arg ltn-policy)))
(defoptimizer (%alien-funcall ir2-convert)
((function type &rest args) call block)
;;; We must only return NIL when it is *certain* that a check will not
;;; be done, since if we pass up this chance to do the check, it will
;;; be too late. The penalty for being too conservative is duplicated
-;;; type checks.
+;;; type checks. The penalty for erring by being too speculative is
+;;; much nastier, e.g. falling through without ever being able to find
+;;; an appropriate VOP.
;;;
;;; If there is a compile-time type error, then we always return true
;;; unless the DEST is a full call. With a full call, the theory is
((function-info-ir2-convert kind) t)
(t
(dolist (template (function-info-templates kind) nil)
- (when (eq (template-policy template) :fast-safe)
+ (when (eq (template-ltn-policy template) :fast-safe)
(multiple-value-bind (val win)
(valid-function-use dest (template-type template))
(when (or val (not win)) (return t)))))))))
#!+sb-show
(defvar *show-transforms-p* nil)
-;;; Do IR1 optimizations on a Combination node.
+;;; Do IR1 optimizations on a COMBINATION node.
(declaim (ftype (function (combination) (values)) ir1-optimize-combination))
(defun ir1-optimize-combination (node)
(when (continuation-reoptimize (basic-combination-fun node))
(dynamic-extent
(when (policy nil (> speed inhibit-warnings))
(compiler-note
- "The DYNAMIC-EXTENT declaration is not implemented (ignored)."))
+ "compiler limitation:~
+ ~% There's no special support for DYNAMIC-EXTENT (so it's ignored)."))
res)
(t
(unless (info :declaration :recognized (first spec))
(declare (type combination call) (type continuation cont)
(type template template) (list rtypes))
(let* ((dtype (node-derived-type call))
- (type (if (and (or (eq (template-policy template) :safe)
+ (type (if (and (or (eq (template-ltn-policy template) :safe)
(policy call (= safety 0)))
(continuation-type-check cont))
(values-type-intersection
arg-locs nargs)))))
(values))
+;;; stuff to check in CHECK-FULL-CALL
+;;;
+;;; There are some things which are intended always to be optimized
+;;; away by DEFTRANSFORMs and such, and so never compiled into full
+;;; calls. This has been a source of bugs so many times that it seems
+;;; worth listing some of them here so that we can check the list
+;;; whenever we compile a full call.
+;;;
+;;; FIXME: It might be better to represent this property by setting a
+;;; flag in DEFKNOWN, instead of representing it by membership in this
+;;; list.
+(defvar *always-optimized-away*
+ '(;; This should always be DEFTRANSFORMed away, but wasn't in a bug
+ ;; reported to cmucl-imp@cons.org 2000-06-20.
+ %instance-ref
+ ;; These should always turn into VOPs, but wasn't in a bug which
+ ;; appeared when LTN-POLICY stuff was being tweaked in
+ ;; sbcl-0.6.9.16. in sbcl-0.6.0
+ data-vector-set
+ data-vector-ref))
+
+;;; more stuff to check in CHECK-FULL-CALL
+;;;
;;; These came in handy when troubleshooting cold boot after making
;;; major changes in the package structure: various transforms and
;;; VOPs and stuff got attached to the wrong symbol, so that
#!+sb-show (defvar *show-full-called-fnames-p* nil)
#!+sb-show (defvar *full-called-fnames* (make-hash-table :test 'equal))
-;;; If the call is in a tail recursive position and the return
-;;; convention is standard, then do a tail full call. If one or fewer
-;;; values are desired, then use a single-value call, otherwise use a
-;;; multiple-values call.
-(defun ir2-convert-full-call (node block)
- (declare (type combination node) (type ir2-block block))
-
+;;; Do some checks on a full call:
+;;; * Is this a full call to something we have reason to know should
+;;; never be full called?
+;;; * Is this a full call to (SETF FOO) which might conflict with
+;;; a DEFSETF or some such thing elsewhere in the program?
+(defun check-full-call (node)
(let* ((cont (basic-combination-fun node))
(fname (continuation-function-name cont t)))
(declare (type (or symbol cons) fname))
#!+sb-show (when *show-full-called-fnames-p*
(/show "converting full call to named function" fname)
(/show (basic-combination-args node))
+ (/show (policy node speed) (policy node safety))
+ (/show (policy node compilation-speed))
(let ((arg-types (mapcar (lambda (maybe-continuation)
(when maybe-continuation
(type-specifier
(basic-combination-args node))))
(/show arg-types)))
+ (when (memq fname *always-optimized-away*)
+ (/show (policy node speed) (policy node safety))
+ (/show (policy node compilation-speed))
+ (error "internal error: full call to ~S" fname))
+
(when (consp fname)
(destructuring-bind (setf stem) fname
(assert (eq setf 'setf))
- (setf (gethash stem *setf-assumed-fboundp*) t))))
+ (setf (gethash stem *setf-assumed-fboundp*) t)))))
+;;; If the call is in a tail recursive position and the return
+;;; convention is standard, then do a tail full call. If one or fewer
+;;; values are desired, then use a single-value call, otherwise use a
+;;; multiple-values call.
+(defun ir2-convert-full-call (node block)
+ (declare (type combination node) (type ir2-block block))
+ (check-full-call node)
(let ((2cont (continuation-info (node-cont node))))
(cond ((node-tail-p node)
(ir2-convert-tail-full-call node block))
(ir2-convert-multiple-full-call node block))
(t
(ir2-convert-fixed-full-call node block))))
-
(values))
\f
;;;; entering functions
\f
;;;; n-argument functions
-(macrolet ((frob (name)
+(macrolet ((def-frob (name)
`(defoptimizer (,name ir2-convert) ((&rest args) node block)
(let* ((refs (move-tail-full-call-args node block))
(cont (node-cont node))
(vop* ,name node block (refs) ((first res) nil)
(length args))
(move-continuation-result node block res cont)))))
- (frob list)
- (frob list*))
+ (def-frob list)
+ (def-frob list*))
\f
;;;; structure accessors
;;;;
\f
;;;; utilities
-;;; Return the policies keyword indicated by the node policy.
-(defun translation-policy (node)
+;;; Return the LTN-POLICY indicated by the node policy.
+;;;
+;;; FIXME: It would be tidier to use an LTN-POLICY object (an instance
+;;; of DEFSTRUCT LTN-POLICY) instead of a keyword, and have queries
+;;; like LTN-POLICY-SAFE-P become slot accessors. If we do this,
+;;; grep for and carefully review use of literal keywords, so that
+;;; things like
+;;; (EQ (TEMPLATE-LTN-POLICY TEMPLATE) :SAFE)
+;;; don't get overlooked.
+;;;
+;;; FIXME: Classic CMU CL went to some trouble to cache LTN-POLICY
+;;; values in LTN-ANALYZE so that they didn't have to be recomputed on
+;;; every block. I stripped that out (the whole DEFMACRO FROB thing)
+;;; because I found it too confusing. Thus, it might be that the
+;;; new uncached code spends an unreasonable amount of time in
+;;; this lookup function. This function should be profiled, and if
+;;; it's a significant contributor to runtime, we can cache it in
+;;; some more local way, e.g. by adding a CACHED-LTN-POLICY slot to
+;;; the NODE structure, and doing something like
+;;; (DEFUN NODE-LTN-POLICY (NODE)
+;;; (OR (NODE-CACHED-LTN-POLICY NODE)
+;;; (SETF (NODE-CACHED-LTN-POLICY NODE)
+;;; (NODE-UNCACHED-LTN-POLICY NODE)))
+(defun node-ltn-policy (node)
(declare (type node node))
(policy node
(let ((eff-space (max space
(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)))
+;;; Return true if LTN-POLICY is a safe policy.
+(defun ltn-policy-safe-p (ltn-policy)
+ (ecase ltn-policy
+ ((:safe :fast-safe) t)
+ ((:small :fast) nil)))
;;; 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))
(when (member (continuation-type-check cont) '(t :no-check))
(setf (continuation-%type-check cont) :deleted))
(values))
-;;; An annotated continuation's primitive-type.
+;;; an annotated continuation's primitive-type
#!-sb-fluid (declaim (inline continuation-ptype))
(defun continuation-ptype (cont)
(declare (type continuation cont))
;;; 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)
+(defun annotate-ordinary-continuation (cont ltn-policy)
(declare (type continuation cont)
- (type policies policy-keyword))
+ (type ltn-policy ltn-policy))
(let ((info (make-ir2-continuation
(primitive-type (continuation-type cont)))))
(setf (continuation-info cont) info)
- (unless (policy-safe-p policy-keyword)
+ (unless (ltn-policy-safe-p ltn-policy)
(flush-type-check cont))
(annotate-1-value-continuation cont))
(values))
;;; Annotate the function continuation for a full call. If the only
-;;; reference is to a global function and Delay is true, then we delay
+;;; 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.
-(defun annotate-function-continuation (cont policy &optional (delay t))
- (declare (type continuation cont) (type policies policy))
- (unless (policy-safe-p policy)
+;;; LTN-POLICY is unsafe, since the check for a valid function
+;;; object must be done before the call.
+(defun annotate-function-continuation (cont ltn-policy &optional (delay t))
+ (declare (type continuation cont) (type ltn-policy ltn-policy))
+ (unless (ltn-policy-safe-p ltn-policy)
(flush-type-check cont))
(let* ((ptype (primitive-type (continuation-type cont)))
(tn-ptype (if (member (continuation-type-check cont) '(:deleted nil))
;;; since IR2tran might decide to call after all.
;;;
;;; If not funny, we always flush arg type checks, but do it after
-;;; annotation when the policy is safe, since we don't want to choose the TNs
-;;; according to a type assertions that may not hold.
+;;; annotation when the LTN-POLICY is safe, since we don't want to
+;;; choose the TNs according to a type assertions that may not hold.
;;;
;;; Note that args may already be annotated because template selection can
;;; bail out to here.
-(defun ltn-default-call (call policy)
- (declare (type combination call) (type policies policy))
+(defun ltn-default-call (call ltn-policy)
+ (declare (type combination call) (type ltn-policy ltn-policy))
(let ((kind (basic-combination-kind call)))
- (annotate-function-continuation (basic-combination-fun call) policy)
+ (annotate-function-continuation (basic-combination-fun call) ltn-policy)
(cond
((and (function-info-p kind)
(continuation-type arg)))))
(annotate-1-value-continuation arg)))
(t
- (let ((safe-p (policy-safe-p policy)))
+ (let ((safe-p (ltn-policy-safe-p ltn-policy)))
(dolist (arg (basic-combination-args call))
(unless safe-p (flush-type-check arg))
(unless (continuation-info arg)
(values))
;;; Annotate a continuation for unknown multiple values:
-;;; -- Delete any type check, regardless of policy, since we IR2 conversion
-;;; isn't prepared to check unknown-values continuations. If we delete a
-;;; type check when the policy is safe, then we emit a warning.
-;;; -- Add the continuation to the IR2-Block-Popped if it is used across a
-;;; block boundary.
-;;; -- Assign a :Unknown IR2-Continuation.
+;;; -- Delete any type check, regardless of LTN-POLICY, since IR2
+;;; conversion isn't prepared to check unknown-values continuations.
+;;; If we delete a type check when the policy is safe, then we emit
+;;; a warning.
+;;; -- Add the continuation to the IR2-BLOCK-POPPED if it is used
+;;; across a block boundary.
+;;; -- Assign an :UNKNOWN IR2-CONTINUATION.
;;;
-;;; Note: it is critical that this be called only during LTN analysis of Cont's
-;;; DEST, and called in the order that the continuations are received.
-;;; Otherwise the IR2-Block-Popped and IR2-Component-Values-XXX will get all
-;;; messed up.
-(defun annotate-unknown-values-continuation (cont policy)
- (declare (type continuation cont) (type policies policy))
+;;; Note: it is critical that this be called only during LTN analysis
+;;; of CONT's DEST, and called in the order that the continuations are
+;;; received. Otherwise the IR2-BLOCK-POPPED and
+;;; IR2-COMPONENT-VALUES-FOO would get all messed up.
+(defun annotate-unknown-values-continuation (cont ltn-policy)
+ (declare (type continuation cont) (type ltn-policy ltn-policy))
(when (eq (continuation-type-check cont) t)
(let* ((dest (continuation-dest cont))
(*compiler-error-context* dest))
- (when (and (policy-safe-p policy)
+ (when (and (ltn-policy-safe-p ltn-policy)
(policy dest (>= safety inhibit-warnings)))
- (compiler-note "unable to check type assertion in unknown-values ~
- context:~% ~S"
+ (compiler-note "compiler limitation: ~
+ unable to check type assertion in ~
+ unknown-values context:~% ~S"
(continuation-asserted-type cont))))
(setf (continuation-%type-check cont) :deleted))
(values))
-;;; Annotate Cont for a fixed, but arbitrary number of values, of the
-;;; specified primitive Types. If the continuation has a type check, we
-;;; annotate for the number of values indicated by Types, but only use proven
-;;; type information.
-(defun annotate-fixed-values-continuation (cont policy types)
- (declare (type continuation cont) (type policies policy) (list types))
- (unless (policy-safe-p policy) (flush-type-check cont))
-
+;;; Annotate CONT for a fixed, but arbitrary number of values, of the
+;;; specified primitive TYPES. If the continuation has a type check,
+;;; we annotate for the number of values indicated by TYPES, but only
+;;; use proven type information.
+(defun annotate-fixed-values-continuation (cont ltn-policy types)
+ (declare (continuation cont) (ltn-policy ltn-policy) (list types))
+ (unless (ltn-policy-safe-p ltn-policy)
+ (flush-type-check cont))
(let ((res (make-ir2-continuation nil)))
(if (member (continuation-type-check cont) '(:deleted nil))
(setf (ir2-continuation-locs res) (mapcar #'make-normal-tn types))
(t
proven)))))
(setf (continuation-info cont) res))
-
(values))
\f
;;;; node-specific analysis functions
-;;; Annotate the result continuation for a function. We use the Return-Info
-;;; computed by GTN to determine how to represent the return values within the
-;;; function:
-;;; -- If the tail-set has a fixed values count, then use that many values.
-;;; -- If the actual uses of the result continuation in this function have a
-;;; fixed number of values (after intersection with the assertion), then use
-;;; that number. We throw out TAIL-P :FULL and :LOCAL calls, since we know
-;;; they will truly end up as TR calls. We can use the
-;;; BASIC-COMBINATION-INFO even though it is assigned by this phase, since
-;;; the initial value NIL doesn't look like a TR call.
-;;;
-;;; If there are *no* non-tail-call uses, then it falls out that we annotate
-;;; for one value (type is NIL), but the return will end up being deleted.
-;;;
-;;; In non-perverse code, the DFO walk will reach all uses of the result
-;;; continuation before it reaches the RETURN. In perverse code, we may
-;;; annotate for unknown values when we didn't have to.
-;;; -- Otherwise, we must annotate the continuation for unknown values.
-(defun ltn-analyze-return (node policy)
- (declare (type creturn node) (type policies policy))
+;;; Annotate the result continuation for a function. We use the
+;;; RETURN-INFO computed by GTN to determine how to represent the
+;;; return values within the function:
+;;; ---- If the tail-set has a fixed values count, then use that
+;;; many values.
+;;; ---- If the actual uses of the result continuation in this function
+;;; have a fixed number of values (after intersection with the
+;;; assertion), then use that number. We throw out TAIL-P :FULL
+;;; and :LOCAL calls, since we know they will truly end up as TR
+;;; calls. We can use the BASIC-COMBINATION-INFO even though it
+;;; is assigned by this phase, since the initial value NIL doesn't
+;;; look like a TR call.
+;;; If there are *no* non-tail-call uses, then it falls out
+;;; that we annotate for one value (type is NIL), but the return
+;;; will end up being deleted.
+;;; In non-perverse code, the DFO walk will reach all uses of
+;;; the result continuation before it reaches the RETURN. In
+;;; perverse code, we may annotate for unknown values when we
+;;; didn't have to.
+;;; ---- Otherwise, we must annotate the continuation for unknown values.
+(defun ltn-analyze-return (node ltn-policy)
+ (declare (type creturn node) (type ltn-policy ltn-policy))
(let* ((cont (return-result node))
(fun (return-lambda node))
(returns (tail-set-info (lambda-tail-set fun)))
(multiple-value-bind (types kind)
(values-types (if (eq int *empty-type*) (res) int))
(if (eq kind :unknown)
- (annotate-unknown-values-continuation cont policy)
+ (annotate-unknown-values-continuation cont ltn-policy)
(annotate-fixed-values-continuation
- cont policy
- (mapcar #'primitive-type types))))))
- (annotate-fixed-values-continuation cont policy types)))
+ cont ltn-policy (mapcar #'primitive-type types))))))
+ (annotate-fixed-values-continuation cont ltn-policy types)))
(values))
;;; Annotate the single argument continuation as a fixed-values
-;;; continuation. We look at the called lambda to determine number and type of
-;;; return values desired. It is assumed that only a function that
-;;; Looks-Like-An-MV-Bind will be converted to a local call.
-(defun ltn-analyze-mv-bind (call policy)
+;;; continuation. We look at the called lambda to determine number and
+;;; type of return values desired. It is assumed that only a function
+;;; that LOOKS-LIKE-AN-MV-BIND will be converted to a local call.
+(defun ltn-analyze-mv-bind (call ltn-policy)
(declare (type mv-combination call)
- (type policies policy))
+ (type ltn-policy ltn-policy))
(setf (basic-combination-kind call) :local)
(setf (node-tail-p call) nil)
(annotate-fixed-values-continuation
- (first (basic-combination-args call)) policy
- (mapcar #'(lambda (var)
- (primitive-type (basic-var-type var)))
+ (first (basic-combination-args call))
+ ltn-policy
+ (mapcar (lambda (var)
+ (primitive-type (basic-var-type var)))
(lambda-vars
(ref-leaf
(continuation-use
(values))
;;; We force all the argument continuations to use the unknown values
-;;; convention. The continuations are annotated in reverse order, since the
-;;; last argument is on top, thus must be popped first. We disallow delayed
-;;; evaluation of the function continuation to simplify IR2 conversion of MV
-;;; call.
+;;; convention. The continuations are annotated in reverse order,
+;;; since the last argument is on top, thus must be popped first. We
+;;; disallow delayed evaluation of the function continuation to
+;;; simplify IR2 conversion of MV call.
;;;
-;;; We could be cleverer when we know the number of values returned by the
-;;; continuations, but optimizations of MV-Call are probably unworthwhile.
+;;; We could be cleverer when we know the number of values returned by
+;;; the continuations, but optimizations of MV call are probably
+;;; unworthwhile.
;;;
-;;; We are also responsible for handling THROW, which is represented in IR1
-;;; as an mv-call to the %THROW funny function. We annotate the tag
-;;; continuation for a single value and the values continuation for unknown
-;;; values.
-(defun ltn-analyze-mv-call (call policy)
- (declare (type mv-combination call))
+;;; We are also responsible for handling THROW, which is represented
+;;; in IR1 as an MV call to the %THROW funny function. We annotate the
+;;; tag continuation for a single value and the values continuation
+;;; for unknown values.
+(defun ltn-analyze-mv-call (call ltn-policy)
+ (declare (type mv-combination call) (type ltn-policy ltn-policy))
(let ((fun (basic-combination-fun call))
(args (basic-combination-args call)))
(cond ((eq (continuation-function-name fun) '%throw)
(setf (basic-combination-info call) :funny)
- (annotate-ordinary-continuation (first args) policy)
- (annotate-unknown-values-continuation (second args) policy)
+ (annotate-ordinary-continuation (first args) ltn-policy)
+ (annotate-unknown-values-continuation (second args) ltn-policy)
(setf (node-tail-p call) nil))
(t
(setf (basic-combination-info call) :full)
(annotate-function-continuation (basic-combination-fun call)
- policy nil)
+ ltn-policy
+ nil)
(dolist (arg (reverse args))
- (annotate-unknown-values-continuation arg policy))
+ (annotate-unknown-values-continuation arg ltn-policy))
(flush-full-call-tail-transfer call))))
(values))
-;;; Annotate the arguments as ordinary single-value continuations. And check
-;;; the successor.
-(defun ltn-analyze-local-call (call policy)
+;;; Annotate the arguments as ordinary single-value continuations. And
+;;; check the successor.
+(defun ltn-analyze-local-call (call ltn-policy)
(declare (type combination call)
- (type policies policy))
+ (type ltn-policy ltn-policy))
(setf (basic-combination-info call) :local)
-
(dolist (arg (basic-combination-args call))
(when arg
- (annotate-ordinary-continuation arg policy)))
-
+ (annotate-ordinary-continuation arg ltn-policy)))
(when (node-tail-p call)
(set-tail-local-call-successor call))
(values))
(values))
;;; Annotate the value continuation.
-(defun ltn-analyze-set (node policy)
- (declare (type cset node) (type policies policy))
+(defun ltn-analyze-set (node ltn-policy)
+ (declare (type cset node) (type ltn-policy ltn-policy))
(setf (node-tail-p node) nil)
- (annotate-ordinary-continuation (set-value node) policy)
+ (annotate-ordinary-continuation (set-value node) ltn-policy)
(values))
-;;; If the only use of the Test continuation is a combination annotated with
-;;; a conditional template, then don't annotate the continuation so that IR2
-;;; conversion knows not to emit any code, otherwise annotate as an ordinary
-;;; continuation. Since we only use a conditional template if the call
-;;; immediately precedes the IF node in the same block, we know that any
-;;; predicate will already be annotated.
-(defun ltn-analyze-if (node policy)
- (declare (type cif node) (type policies policy))
+;;; If the only use of the TEST continuation is a combination
+;;; annotated with a conditional template, then don't annotate the
+;;; continuation so that IR2 conversion knows not to emit any code,
+;;; otherwise annotate as an ordinary continuation. Since we only use
+;;; a conditional template if the call immediately precedes the IF
+;;; node in the same block, we know that any predicate will already be
+;;; annotated.
+(defun ltn-analyze-if (node ltn-policy)
+ (declare (type cif node) (type ltn-policy ltn-policy))
(setf (node-tail-p node) nil)
(let* ((test (if-test node))
(use (continuation-use test)))
(let ((info (basic-combination-info use)))
(and (template-p info)
(eq (template-result-types info) :conditional))))
- (annotate-ordinary-continuation test policy)))
+ (annotate-ordinary-continuation test ltn-policy)))
(values))
-;;; If there is a value continuation, then annotate it for unknown values.
-;;; In this case, the exit is non-local, since all other exits are deleted or
-;;; degenerate by this point.
-(defun ltn-analyze-exit (node policy)
+;;; If there is a value continuation, then annotate it for unknown
+;;; values. In this case, the exit is non-local, since all other exits
+;;; are deleted or degenerate by this point.
+(defun ltn-analyze-exit (node ltn-policy)
(setf (node-tail-p node) nil)
(let ((value (exit-value node)))
(when value
- (annotate-unknown-values-continuation value policy)))
+ (annotate-unknown-values-continuation value ltn-policy)))
(values))
-;;; We need a special method for %Unwind-Protect that ignores the cleanup
-;;; function. We don't annotate either arg, since we don't need them at
-;;; run-time.
+;;; We need a special method for %UNWIND-PROTECT that ignores the
+;;; cleanup function. We don't annotate either arg, since we don't
+;;; need them at run-time.
;;;
-;;; [The default is o.k. for %Catch, since environment analysis converted the
-;;; reference to the escape function into a constant reference to the
-;;; NLX-Info.]
-(defoptimizer (%unwind-protect ltn-annotate) ((escape cleanup) node policy)
- policy ; Ignore...
+;;; (The default is o.k. for %CATCH, since environment analysis
+;;; converted the reference to the escape function into a constant
+;;; reference to the NLX-INFO.)
+(defoptimizer (%unwind-protect ltn-annotate) ((escape cleanup)
+ node
+ ltn-policy)
+ (declare (ignore ltn-policy))
(setf (basic-combination-info node) :funny)
(setf (node-tail-p node) nil))
-;;; Both of these functions need special LTN-annotate methods, since we only
-;;; want to clear the Type-Check in unsafe policies. If we allowed the call to
-;;; be annotated as a full call, then no type checking would be done.
+;;; Both of these functions need special LTN-annotate methods, since
+;;; we only want to clear the TYPE-CHECK in unsafe policies. If we
+;;; allowed the call to be annotated as a full call, then no type
+;;; checking would be done.
;;;
-;;; We also need a special LTN annotate method for %Slot-Setter so that the
-;;; function is ignored. This is because the reference to a SETF function
-;;; can't be delayed, so IR2 conversion would have already emitted a call to
-;;; FDEFINITION by the time the IR2 convert method got control.
-(defoptimizer (%slot-accessor ltn-annotate) ((struct) node policy)
+;;; We also need a special LTN annotate method for %SLOT-SETTER so
+;;; that the function is ignored. This is because the reference to a
+;;; SETF function can't be delayed, so IR2 conversion would have
+;;; already emitted a call to FDEFINITION by the time the IR2 convert
+;;; method got control.
+(defoptimizer (%slot-accessor ltn-annotate) ((struct) node ltn-policy)
(setf (basic-combination-info node) :funny)
(setf (node-tail-p node) nil)
- (annotate-ordinary-continuation struct policy))
-(defoptimizer (%slot-setter ltn-annotate) ((struct value) node policy)
+ (annotate-ordinary-continuation struct ltn-policy))
+(defoptimizer (%slot-setter ltn-annotate) ((struct value) node ltn-policy)
(setf (basic-combination-info node) :funny)
(setf (node-tail-p node) nil)
- (annotate-ordinary-continuation struct policy)
- (annotate-ordinary-continuation value policy))
+ (annotate-ordinary-continuation struct ltn-policy)
+ (annotate-ordinary-continuation value ltn-policy))
\f
;;;; known call annotation
-;;; Return true if Restr is satisfied by Type. If T-OK is true, then a T
-;;; restriction allows any operand type. This is also called by IR2tran when
-;;; it determines whether a result temporary needs to be made, and by
-;;; representation selection when it is deciding which move VOP to use.
-;;; Cont and TN are used to test for constant arguments.
-#!-sb-fluid (declaim (inline operand-restriction-ok))
+;;; Return true if RESTR is satisfied by TYPE. If T-OK is true, then a
+;;; T restriction allows any operand type. This is also called by IR2
+;;; translation when it determines whether a result temporary needs to
+;;; be made, and by representation selection when it is deciding which
+;;; move VOP to use. CONT and TN are used to test for constant
+;;; arguments.
(defun operand-restriction-ok (restr type &key cont tn (t-ok t))
(declare (type (or (member *) cons) restr)
(type primitive-type type)
(t
(error "Neither CONT nor TN supplied.")))))))
-;;; Check that the argument type restriction for Template are satisfied in
-;;; call. If an argument's TYPE-CHECK is :NO-CHECK and our policy is safe,
-;;; then only :SAFE templates are o.k.
+;;; Check that the argument type restriction for TEMPLATE are
+;;; satisfied in call. If an argument's TYPE-CHECK is :NO-CHECK and
+;;; our policy is safe, then only :SAFE templates are OK.
(defun template-args-ok (template call safe-p)
(declare (type template template)
(type combination call))
(type (car types)))
(when (and (eq (continuation-type-check arg) :no-check)
safe-p
- (not (eq (template-policy template) :safe)))
+ (not (eq (template-ltn-policy template) :safe)))
(return nil))
(unless (operand-restriction-ok type (continuation-ptype arg)
:cont arg)
(return nil))))))
-;;; Check that Template can be used with the specifed Result-Type. Result
-;;; type checking is pretty different from argument type checking due to the
-;;; relaxed rules for values count. We succeed if for each required result,
-;;; there is a positional restriction on the value that is at least as good.
-;;; If we run out of result types before we run out of restrictions, then we
-;;; only succeed if the leftover restrictions are *. If we run out of
-;;; restrictions before we run out of result types, then we always win.
+;;; Check that TEMPLATE can be used with the specifed RESULT-TYPE.
+;;; Result type checking is pretty different from argument type
+;;; checking due to the relaxed rules for values count. We succeed if
+;;; for each required result, there is a positional restriction on the
+;;; value that is at least as good. If we run out of result types
+;;; before we run out of restrictions, then we only succeed if the
+;;; leftover restrictions are *. If we run out of restrictions before
+;;; we run out of result types, then we always win.
(defun template-results-ok (template result-type)
(declare (type template template)
(type ctype result-type))
(operand-restriction-ok (first types) (primitive-type result-type)))
(t t))))
-;;; Return true if Call is an ok use of Template according to Safe-P.
-;;; -- If the template has a Guard that isn't true, then we ignore the
+;;; Return true if CALL is an ok use of TEMPLATE according to SAFE-P.
+;;; -- If the template has a GUARD that isn't true, then we ignore the
;;; template, not even considering it to be rejected.
-;;; -- If the argument type restrictions aren't satisfied, then we reject the
-;;; template.
-;;; -- If the template is :Conditional, then we accept it only when the
+;;; -- If the argument type restrictions aren't satisfied, then we
+;;; reject the template.
+;;; -- If the template is :CONDITIONAL, then we accept it only when the
;;; destination of the value is an immediately following IF node.
-;;; -- If either the template is safe or the policy is unsafe (i.e. we can
-;;; believe output assertions), then we test against the intersection of the
-;;; node derived type and the continuation asserted type. Otherwise, we
-;;; just use the node type. If TYPE-CHECK is null, there is no point in
-;;; doing the intersection, since the node type must be a subtype of the
-;;; assertion.
+;;; -- If either the template is safe or the policy is unsafe (i.e. we
+;;; can believe output assertions), then we test against the
+;;; intersection of the node derived type and the continuation
+;;; asserted type. Otherwise, we just use the node type. If
+;;; TYPE-CHECK is null, there is no point in doing the intersection,
+;;; since the node type must be a subtype of the assertion.
;;;
-;;; If the template is *not* ok, then the second value is a keyword indicating
-;;; which aspect failed.
+;;; If the template is *not* ok, then the second value is a keyword
+;;; indicating which aspect failed.
(defun is-ok-template-use (template call safe-p)
(declare (type template template) (type combination call))
(let* ((guard (template-guard template))
(values nil :conditional))))
((template-results-ok
template
- (if (and (or (eq (template-policy template) :safe)
+ (if (and (or (eq (template-ltn-policy template) :safe)
(not safe-p))
(continuation-type-check cont))
(values-type-intersection dtype atype)
(values nil :result-types)))))
;;; Use operand type information to choose a template from the list
-;;; Templates for a known Call. We return three values:
+;;; TEMPLATES for a known CALL. We return three values:
;;; 1. The template we found.
;;; 2. Some template that we rejected due to unsatisfied type restrictions, or
;;; NIL if none.
(return (values template rejected (rest templates))))
(setq rejected template))))
-;;; Given a partially annotated known call and a translation policy, return
-;;; the appropriate template, or NIL if none can be found. We scan the
-;;; templates (ordered by increasing cost) looking for a template whose
-;;; restrictions are satisfied and that has our policy.
+;;; Given a partially annotated known call and a translation policy,
+;;; return the appropriate template, or NIL if none can be found. We
+;;; scan the templates (ordered by increasing cost) looking for a
+;;; template whose restrictions are satisfied and that has our policy.
;;;
-;;; If we find a template that doesn't have our policy, but has a legal
-;;; alternate policy, then we also record that to return as a last resort. If
-;;; our policy is safe, then only safe policies are O.K., otherwise anything
-;;; goes.
+;;; If we find a template that doesn't have our policy, but has a
+;;; legal alternate policy, then we also record that to return as a
+;;; last resort. If our policy is safe, then only safe policies are
+;;; O.K., otherwise anything goes.
;;;
-;;; If we find a template with :SAFE policy, then we return it, or any cheaper
-;;; fallback template. The theory behind this is that if it is cheapest, small
-;;; and safe, we can't lose. If it is not cheapest, then we use the fallback,
-;;; which won't have the desired policy, but :SAFE isn't desired either, so we
-;;; might as well go with the cheaper one. The main reason for doing this is
-;;; to make sure that cheap safe templates are used when they apply and the
-;;; current policy is something else. This is useful because :SAFE has the
-;;; additional semantics of implicit argument type checking, so we may be
-;;; forced to define a template with :SAFE policy when it is really small and
-;;; fast as well.
-(defun find-template-for-policy (call policy)
+;;; If we find a template with :SAFE policy, then we return it, or any
+;;; cheaper fallback template. The theory behind this is that if it is
+;;; cheapest, small and safe, we can't lose. If it is not cheapest,
+;;; then we use the fallback, which won't have the desired policy, but
+;;; :SAFE isn't desired either, so we might as well go with the
+;;; cheaper one. The main reason for doing this is to make sure that
+;;; cheap safe templates are used when they apply and the current
+;;; policy is something else. This is useful because :SAFE has the
+;;; additional semantics of implicit argument type checking, so we may
+;;; be forced to define a template with :SAFE policy when it is really
+;;; small and fast as well.
+(defun find-template-for-ltn-policy (call ltn-policy)
(declare (type combination call)
- (type policies policy))
- (let ((safe-p (policy-safe-p policy))
+ (type ltn-policy ltn-policy))
+ (let ((safe-p (ltn-policy-safe-p ltn-policy))
(current (function-info-templates (basic-combination-kind call)))
(fallback nil)
(rejected nil))
(setq current more)
(unless template
(return (values fallback rejected)))
-
- (let ((tpolicy (template-policy template)))
- (cond ((eq tpolicy policy)
+ (let ((tcpolicy (template-ltn-policy template)))
+ (cond ((eq tcpolicy ltn-policy)
(return (values template rejected)))
- ((eq tpolicy :safe)
+ ((eq tcpolicy :safe)
(return (values (or fallback template) rejected)))
- ((or (not safe-p) (eq tpolicy :fast-safe))
+ ((or (not safe-p) (eq tcpolicy :fast-safe))
(unless fallback
(setq fallback template)))))))))
the next alternative that justifies an efficiency note.")
(declaim (type index *efficiency-note-cost-threshold*))
-;;; This function is called by NOTE-REJECTED-TEMPLATES when it can't figure
-;;; out any reason why Template was rejected. Users should never see these
-;;; messages, but they can happen in situations where the VM definition is
-;;; messed up somehow.
-(defun strange-template-failure (template call policy frob)
+;;; This function is called by NOTE-REJECTED-TEMPLATES when it can't
+;;; figure out any reason why TEMPLATE was rejected. Users should
+;;; never see these messages, but they can happen in situations where
+;;; the VM definition is messed up somehow.
+(defun strange-template-failure (template call ltn-policy frob)
(declare (type template template) (type combination call)
- (type policies policy) (type function frob))
+ (type ltn-policy ltn-policy) (type function frob))
(funcall frob "This shouldn't happen! Bug?")
(multiple-value-bind (win why)
- (is-ok-template-use template call (policy-safe-p policy))
+ (is-ok-template-use template call (ltn-policy-safe-p ltn-policy))
(assert (not win))
(ecase why
(:guard
(:result-types
(funcall frob "result types invalid")))))
-;;; This function emits efficiency notes describing all of the templates
-;;; better (faster) than Template that we might have been able to use if there
-;;; were better type declarations. Template is null when we didn't find any
-;;; template, and thus must do a full call.
+;;; This function emits efficiency notes describing all of the
+;;; templates better (faster) than TEMPLATE that we might have been
+;;; able to use if there were better type declarations. Template is
+;;; null when we didn't find any template, and thus must do a full
+;;; call.
;;;
;;; In order to be worth complaining about, a template must:
;;; -- be allowed by its guard,
;;; -- be safe if the current policy is safe,
-;;; -- have argument/result type restrictions consistent with the known type
-;;; information, e.g. we don't consider float templates when an operand is
-;;; known to be an integer,
-;;; -- be disallowed by the stricter operand subtype test (which resembles, but
-;;; is not identical to the test done by Find-Template.)
+;;; -- have argument/result type restrictions consistent with the
+;;; known type information, e.g. we don't consider float templates
+;;; when an operand is known to be an integer,
+;;; -- be disallowed by the stricter operand subtype test (which
+;;; resembles, but is not identical to the test done by
+;;; FIND-TEMPLATE.)
;;;
-;;; Note that there may not be any possibly applicable templates, since we are
-;;; called whenever any template is rejected. That template might have the
-;;; wrong policy or be inconsistent with the known type.
+;;; Note that there may not be any possibly applicable templates,
+;;; since we are called whenever any template is rejected. That
+;;; template might have the wrong policy or be inconsistent with the
+;;; known type.
;;;
-;;; We go to some trouble to make the whole multi-line output into a single
-;;; call to Compiler-Note so that repeat messages are suppressed, etc.
-(defun note-rejected-templates (call policy template)
- (declare (type combination call) (type policies policy)
+;;; We go to some trouble to make the whole multi-line output into a
+;;; single call to COMPILER-NOTE so that repeat messages are
+;;; suppressed, etc.
+(defun note-rejected-templates (call ltn-policy template)
+ (declare (type combination call) (type ltn-policy ltn-policy)
(type (or template null) template))
(collect ((losers))
- (let ((safe-p (policy-safe-p policy))
+ (let ((safe-p (ltn-policy-safe-p ltn-policy))
(verbose-p (policy call (= inhibit-warnings 0)))
(max-cost (- (template-cost
(or template
(template-or-lose 'call-named)))
*efficiency-note-cost-threshold*)))
(dolist (try (function-info-templates (basic-combination-kind call)))
- (when (> (template-cost try) max-cost) (return))
+ (when (> (template-cost try) max-cost) (return)) ; FIXME: UNLESS'd be cleaner.
(let ((guard (template-guard try)))
(when (and (or (not guard) (funcall guard))
(or (not safe-p)
- (policy-safe-p (template-policy try)))
+ (ltn-policy-safe-p (template-ltn-policy try)))
(or verbose-p
(and (template-note try)
(valid-function-use
(template-cost loser))
(cond
((and valid strict-valid)
- (strange-template-failure loser call policy #'frob))
+ (strange-template-failure loser call ltn-policy #'frob))
((not valid)
(assert (not (valid-function-use call type
:error-function #'frob
:warning-function #'frob))))
(t
- (assert (policy-safe-p policy))
+ (assert (ltn-policy-safe-p ltn-policy))
(frob "can't trust output type assertion under safe policy")))
(count 1))))
;;; the policy is safe because the selection of template for results
;;; readers assumes the type check is done (uses the derived type
;;; which is the intersection of the proven and asserted types).
-(defun flush-type-checks-according-to-policy (call policy template)
- (declare (type combination call) (type policies policy)
+(defun flush-type-checks-according-to-ltn-policy (call ltn-policy template)
+ (declare (type combination call) (type ltn-policy ltn-policy)
(type template template))
- (let ((safe-op (eq (template-policy template) :safe)))
- (when (or (not (policy-safe-p policy)) safe-op)
+ (let ((safe-op (eq (template-ltn-policy template) :safe)))
+ (when (or (not (ltn-policy-safe-p ltn-policy)) safe-op)
(dolist (arg (basic-combination-args call))
(flush-type-check arg)))
(when safe-op
(let ((cont (node-cont call)))
(when (and (eq (continuation-use cont) call)
- (not (policy-safe-p policy)))
+ (not (ltn-policy-safe-p ltn-policy)))
(flush-type-check cont)))))
(values))
-;;; If a function has a special-case annotation method use that, otherwise
-;;; annotate the argument continuations and try to find a template
-;;; corresponding to the type signature. If there is none, convert a full call.
-(defun ltn-analyze-known-call (call policy)
+;;; If a function has a special-case annotation method use that,
+;;; otherwise annotate the argument continuations and try to find a
+;;; template corresponding to the type signature. If there is none,
+;;; convert a full call.
+(defun ltn-analyze-known-call (call ltn-policy)
(declare (type combination call)
- (type policies policy))
+ (type ltn-policy ltn-policy))
(let ((method (function-info-ltn-annotate (basic-combination-kind call)))
(args (basic-combination-args call)))
(when method
- (funcall method call policy)
+ (funcall method call ltn-policy)
(return-from ltn-analyze-known-call (values)))
(dolist (arg args)
(make-ir2-continuation (primitive-type (continuation-type arg)))))
(multiple-value-bind (template rejected)
- (find-template-for-policy call policy)
- ;; If we are unable to use some templates due to unsatisfied operand type
- ;; restrictions and our policy enables efficiency notes, then we call
- ;; Note-Rejected-Templates.
+ (find-template-for-ltn-policy call ltn-policy)
+ ;; If we are unable to use some templates due to unsatisfied
+ ;; operand type restrictions and our policy enables efficiency
+ ;; notes, then we call NOTE-REJECTED-TEMPLATES.
(when (and rejected
(policy call (> speed inhibit-warnings)))
- (note-rejected-templates call policy template))
+ (note-rejected-templates call ltn-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
;; give a warning, as this is probably a botched interpreter stub.
recursive)))))
(let ((*compiler-error-context* call))
(compiler-warning "recursive known function definition")))
- (ltn-default-call call policy)
+ (ltn-default-call call ltn-policy)
(return-from ltn-analyze-known-call (values)))
(setf (basic-combination-info call) template)
(setf (node-tail-p call) nil)
- (flush-type-checks-according-to-policy call policy template)
+ (flush-type-checks-according-to-ltn-policy call ltn-policy template)
(dolist (arg args)
(annotate-1-value-continuation arg))))
\f
;;;; interfaces
-;;; We make the main per-block code in for LTN into a macro so that it can
-;;; be shared between LTN-Analyze and LTN-Analyze-Block, yet can cache policy
-;;; across blocks in the normal (full component) case.
+;;; most of the guts of the two interface functions: Compute the
+;;; policy and dispatch to the appropriate node-specific function.
;;;
-;;; This code computes the policy and then dispatches to the appropriate
-;;; node-specific function.
-;;;
-;;; Note: we deliberately don't use the DO-NODES macro, since the block can be
-;;; split out from underneath us, and DO-NODES would scan past the block end in that
-;;; case.
-(macrolet ((frob ()
- '(do* ((node (continuation-next (block-start block))
- (continuation-next cont))
- (cont (node-cont node) (node-cont node))
- ;; KLUDGE: Since LEXENV and POLICY seem to be only used
- ;; inside this FROB, why not define them in here instead of
- ;; requiring them to be defined externally both in
- ;; LTN-ANALYZE and LTN-ANALYZE-BLOCK? Or perhaps just
- ;; define this whole FROB as an inline function? (Right now
- ;; I don't want to make even a small unnecessary change
- ;; like this, but'd prefer to wait until the system runs so
- ;; that I can test it immediately after the change.)
- ;; -- WHN 19990808
- )
- (())
- (unless (eq (node-lexenv node) lexenv)
- (setq policy (translation-policy node))
- (setq lexenv (node-lexenv node)))
-
- (etypecase node
- (ref)
- (combination
- (case (basic-combination-kind node)
- (:local (ltn-analyze-local-call node policy))
- ((:full :error) (ltn-default-call node policy))
- (t
- (ltn-analyze-known-call node policy))))
- (cif
- (ltn-analyze-if node policy))
- (creturn
- (ltn-analyze-return node policy))
- ((or bind entry))
- (exit
- (ltn-analyze-exit node policy))
- (cset (ltn-analyze-set node policy))
- (mv-combination
- (ecase (basic-combination-kind node)
- (:local (ltn-analyze-mv-bind node policy))
- ((:full :error) (ltn-analyze-mv-call node policy)))))
-
- (when (eq node (block-last block))
- (return)))))
-
-;;; Loop over the blocks in Component, doing stuff to nodes that receive
-;;; values. In addition to the stuff done by FROB, we also see whether there
-;;; are any unknown values receivers, making notations in the components
-;;; Generators and Receivers as appropriate.
+;;; Note: we deliberately don't use the DO-NODES macro, since the
+;;; block can be split out from underneath us, and DO-NODES would scan
+;;; past the block end in that case.
+(defun ltn-analyze-block (block)
+ (do* ((node (continuation-next (block-start block))
+ (continuation-next cont))
+ (cont (node-cont node) (node-cont node))
+ (ltn-policy (node-ltn-policy node) (node-ltn-policy node)))
+ (nil)
+ (etypecase node
+ (ref)
+ (combination
+ (case (basic-combination-kind node)
+ (:local (ltn-analyze-local-call node ltn-policy))
+ ((:full :error) (ltn-default-call node ltn-policy))
+ (t
+ (ltn-analyze-known-call node ltn-policy))))
+ (cif
+ (ltn-analyze-if node ltn-policy))
+ (creturn
+ (ltn-analyze-return node ltn-policy))
+ ((or bind entry))
+ (exit
+ (ltn-analyze-exit node ltn-policy))
+ (cset (ltn-analyze-set node ltn-policy))
+ (mv-combination
+ (ecase (basic-combination-kind node)
+ (:local
+ (ltn-analyze-mv-bind node ltn-policy))
+ ((:full :error)
+ (ltn-analyze-mv-call node ltn-policy)))))
+ (when (eq node (block-last block))
+ (return))))
+
+;;; Loop over the blocks in COMPONENT, doing stuff to nodes that
+;;; receive values. In addition to the stuff done by FROB, we also see
+;;; whether there are any unknown values receivers, making notations
+;;; in the components Generators and Receivers as appropriate.
;;;
;;; If any unknown-values continations are received by this block (as
-;;; indicated by IR2-Block-Popped, then we add the block to the
-;;; IR2-Component-Values-Receivers.
+;;; indicated by IR2-BLOCK-POPPED), then we add the block to the
+;;; IR2-COMPONENT-VALUES-RECEIVERS.
;;;
-;;; This is where we allocate IR2 blocks because it is the first place we
-;;; need them.
+;;; This is where we allocate IR2 blocks because it is the first place
+;;; we need them.
(defun ltn-analyze (component)
(declare (type component component))
- (let ((2comp (component-info component))
- (lexenv nil)
- policy)
+ (let ((2comp (component-info component)))
(do-blocks (block component)
(assert (not (block-info block)))
(let ((2block (make-ir2-block block)))
(setf (block-info block) 2block)
- (frob)
+ (ltn-analyze-block block)
(let ((popped (ir2-block-popped 2block)))
(when popped
(push block (ir2-component-values-receivers 2comp)))))))
(values))
-;;; This function is used to analyze blocks that must be added to the flow
-;;; graph after the normal LTN phase runs. Such code is constrained not to
-;;; use weird unknown values (and probably in lots of other ways).
-(defun ltn-analyze-block (block)
+;;; This function is used to analyze blocks that must be added to the
+;;; flow graph after the normal LTN phase runs. Such code is
+;;; constrained not to use weird unknown values (and probably in lots
+;;; of other ways).
+(defun ltn-analyze-belated-block (block)
(declare (type cblock block))
- (let ((lexenv nil)
- policy)
- (frob))
+ (ltn-analyze-block block)
(assert (not (ir2-block-popped (block-info block))))
(values))
-) ; MACROLET FROB
(values (cdr ,n-res) t)
(values nil nil))))
\f
-;;; These functions are called by the expansion of the DEFPRINTER
-;;; macro to do the actual printing.
-(declaim (ftype (function (symbol t stream &optional t) (values))
- defprinter-prin1 defprinter-princ))
-(defun defprinter-prin1 (name value stream &optional indent)
- (declare (ignore indent))
- (defprinter-prinx #'prin1 name value stream))
-(defun defprinter-princ (name value stream &optional indent)
- (declare (ignore indent))
- (defprinter-prinx #'princ name value stream))
-(defun defprinter-prinx (prinx name value stream)
- (declare (type function prinx))
- (write-char #\space stream)
- (when *print-pretty*
- (pprint-newline :linear stream))
- (format stream ":~A " name)
- (funcall prinx value stream)
- (values))
-
-;; Define some kind of reasonable PRINT-OBJECT method for a STRUCTURE-OBJECT.
-;;
-;; NAME is the name of the structure class, and CONC-NAME is the same as in
-;; DEFSTRUCT.
-;;
-;; The SLOT-DESCS describe how each slot should be printed. Each SLOT-DESC can
-;; be a slot name, indicating that the slot should simply be printed. A
-;; SLOT-DESC may also be a list of a slot name and other stuff. The other stuff
-;; is composed of keywords followed by expressions. The expressions are
-;; evaluated with the variable which is the slot name bound to the value of the
-;; slot. These keywords are defined:
-;;
-;; :PRIN1 Print the value of the expression instead of the slot value.
-;; :PRINC Like :PRIN1, only princ the value
-;; :TEST Only print something if the test is true.
-;;
-;; If no printing thing is specified then the slot value is printed as PRIN1.
-;;
-;; The structure being printed is bound to STRUCTURE and the stream is bound to
-;; STREAM.
-(defmacro defprinter ((name &key (conc-name (concatenate 'simple-string
- (symbol-name name)
- "-")))
- &rest slot-descs)
- (flet ((sref (slot-name)
- `(,(symbolicate conc-name slot-name) structure)))
- (collect ((prints))
- (dolist (slot-desc slot-descs)
- (if (atom slot-desc)
- (prints `(defprinter-prin1 ',slot-desc ,(sref slot-desc) stream))
- (let ((sname (first slot-desc))
- (test t))
- (collect ((stuff))
- (do ((option (rest slot-desc) (cddr option)))
- ((null option)
- (prints
- `(let ((,sname ,(sref sname)))
- (when ,test
- ,@(or (stuff)
- `((defprinter-prin1 ',sname ,sname
- stream)))))))
- (case (first option)
- (:prin1
- (stuff `(defprinter-prin1 ',sname ,(second option)
- stream)))
- (:princ
- (stuff `(defprinter-princ ',sname ,(second option)
- stream)))
- (:test (setq test (second option)))
- (t
- (error "bad DEFPRINTER option: ~S" (first option)))))))))
-
- `(def!method print-object ((structure ,name) stream)
- (print-unreadable-object (structure stream :type t)
- (pprint-logical-block (stream nil)
- ;;(pprint-indent :current 2 stream)
- ,@(prints)))))))
-\f
-;;;; the Event statistics/trace utility
+;;;; the EVENT statistics/trace utility
;;; FIXME: This seems to be useful for troubleshooting and
;;; experimentation, not for ordinary use, so it should probably
(make-array ',size
:initial-element
#-(or sb-xc sb-xc-host) #*
- ;; The cross-compiler isn't very good at
- ;; dumping specialized arrays; we work around
- ;; that by postponing generation of the
- ;; specialized array 'til runtime.
+ ;; The cross-compiler isn't very good
+ ;; at dumping specialized arrays; we
+ ;; work around that by postponing
+ ;; generation of the specialized
+ ;; array 'til runtime.
#+(or sb-xc sb-xc-host)
(make-array 0 :element-type 'bit)))
(/show0 "doing second SETF")
(or (gethash name *backend-meta-primitive-type-names*)
(error "~S is not a defined primitive type." name))))
-;;; If the primitive-type structure already exists, we destructively modify
-;;; it so that existing references in templates won't be invalidated.
+;;; If the PRIMITIVE-TYPE structure already exists, we destructively
+;;; modify it so that existing references in templates won't be
+;;; invalidated.
(defmacro def-primitive-type (name scs &key (type name))
#!+sb-doc
"Def-Primitive-Type Name (SC*) {Key Value}*
\f
;;;; VOP definition structures
;;;;
-;;;; Define-VOP uses some fairly complex data structures at meta-compile
-;;;; time, both to hold the results of parsing the elaborate syntax and to
-;;;; retain the information so that it can be inherited by other VOPs.
+;;;; DEFINE-VOP uses some fairly complex data structures at
+;;;; meta-compile time, both to hold the results of parsing the
+;;;; elaborate syntax and to retain the information so that it can be
+;;;; inherited by other VOPs.
-;;; The VOP-Parse structure holds everything we need to know about a VOP at
+;;; A VOP-PARSE object holds everything we need to know about a VOP at
;;; meta-compile time.
(def!struct (vop-parse
(:make-load-form-fun just-dump-it-normally)
#-sb-xc-host (:pure t))
- ;; The name of this VOP.
+ ;; the name of this VOP
(name nil :type symbol)
;; If true, then the name of the VOP we inherit from.
(inherits nil :type (or symbol null))
- ;; Lists of Operand-Parse structures describing the arguments, results and
- ;; temporaries of the VOP.
+ ;; lists of OPERAND-PARSE structures describing the arguments,
+ ;; results and temporaries of the VOP
(args nil :type list)
(results nil :type list)
(temps nil :type list)
- ;; Operand-Parse structures containing information about more args and
- ;; results. If null, then there there are no more operands of that kind.
+ ;; OPERAND-PARSE structures containing information about more args
+ ;; and results. If null, then there there are no more operands of
+ ;; that kind
(more-args nil :type (or operand-parse null))
(more-results nil :type (or operand-parse null))
- ;; A list of all the above together.
+ ;; a list of all the above together
(operands nil :type list)
- ;; Names of variables that should be declared ignore.
+ ;; names of variables that should be declared IGNORE
(ignores () :type list)
- ;; True if this is a :Conditional VOP.
+ ;; true if this is a :CONDITIONAL VOP
(conditional-p nil)
- ;; Argument and result primitive types. These are pulled out of the
- ;; operands, since we often want to change them without respecifying the
- ;; operands.
+ ;; argument and result primitive types. These are pulled out of the
+ ;; operands, since we often want to change them without respecifying
+ ;; the operands.
(arg-types :unspecified :type (or (member :unspecified) list))
(result-types :unspecified :type (or (member :unspecified) list))
- ;; The guard expression specified, or NIL if none.
+ ;; the guard expression specified, or NIL if none
(guard nil)
- ;; The cost of and body code for the generator.
+ ;; the cost of and body code for the generator
(cost 0 :type unsigned-byte)
(body :unspecified :type (or (member :unspecified) list))
- ;; Info for VOP variants. The list of forms to be evaluated to get the
- ;; variant args for this VOP, and the list of variables to be bound to the
- ;; variant args.
+ ;; info for VOP variants. The list of forms to be evaluated to get
+ ;; the variant args for this VOP, and the list of variables to be
+ ;; bound to the variant args.
(variant () :type list)
(variant-vars () :type list)
- ;; Variables bound to the VOP and Vop-Node when in the generator body.
+ ;; variables bound to the VOP and Vop-Node when in the generator body
(vop-var (gensym) :type symbol)
(node-var nil :type (or symbol null))
- ;; A list of the names of the codegen-info arguments to this VOP.
+ ;; a list of the names of the codegen-info arguments to this VOP
(info-args () :type list)
- ;; An efficiency note associated with this VOP.
+ ;; an efficiency note associated with this VOP
(note nil :type (or string null))
- ;; A list of the names of the Effects and Affected attributes for this VOP.
+ ;; a list of the names of the Effects and Affected attributes for
+ ;; this VOP
(effects '(any) :type list)
(affected '(any) :type list)
- ;; A list of the names of functions this VOP is a translation of and the
- ;; policy that allows this translation to be done. :Fast is a safe default,
- ;; since it isn't a safe policy.
+ ;; a list of the names of functions this VOP is a translation of and
+ ;; the policy that allows this translation to be done. :Fast is a
+ ;; safe default, since it isn't a safe policy.
(translate () :type list)
- (policy :fast :type policies)
- ;; Stuff used by life analysis.
+ (ltn-policy :fast :type ltn-policy)
+ ;; stuff used by life analysis
(save-p nil :type (member t nil :compute-only :force-to-stack))
- ;; Info about how to emit move-argument VOPs for the more operand in
- ;; call/return VOPs.
+ ;; info about how to emit move-argument VOPs for the more operand in
+ ;; call/return VOPs
(move-args nil :type (member nil :local-call :full-call :known-return)))
-
(defprinter (vop-parse)
name
(inherits :test inherits)
effects
affected
translate
- policy
+ ltn-policy
(save-p :test save-p)
(move-args :test move-args))
-;;; An OPERAND-PARSE object contains stuff we need to know about an operand or
-;;; temporary at meta-compile time. Besides the obvious stuff, we also store
-;;; the names of per-operand temporaries here.
+;;; An OPERAND-PARSE object contains stuff we need to know about an
+;;; operand or temporary at meta-compile time. Besides the obvious
+;;; stuff, we also store the names of per-operand temporaries here.
(def!struct (operand-parse
(:make-load-form-fun just-dump-it-normally)
#-sb-xc-host (:pure t))
- ;; Name of the operand (which we bind to the TN).
+ ;; name of the operand (which we bind to the TN)
(name nil :type symbol)
- ;; The way this operand is used:
+ ;; the way this operand is used:
(kind (required-argument)
:type (member :argument :result :temporary
:more-argument :more-result))
- ;; If true, the name of an operand that this operand is targeted to. This is
- ;; only meaningful in :Argument and :Temporary operands.
+ ;; If true, the name of an operand that this operand is targeted to.
+ ;; This is only meaningful in :ARGUMENT and :TEMPORARY operands.
(target nil :type (or symbol null))
- ;; Temporary that holds the TN-Ref for this operand. Temp-Temp holds the
- ;; write reference that begins a temporary's lifetime.
+ ;; TEMP is a temporary that holds the TN-REF for this operand.
+ ;; TEMP-TEMP holds the write reference that begins a temporary's
+ ;; lifetime.
(temp (gensym) :type symbol)
(temp-temp nil :type (or symbol null))
- ;; The time that this operand is first live and the time at which it becomes
- ;; dead again. These are time-specs, as returned by parse-time-spec.
+ ;; the time that this operand is first live and the time at which it
+ ;; becomes dead again. These are TIME-SPECs, as returned by
+ ;; PARSE-TIME-SPEC.
born
dies
- ;; A list of the names of the SCs that this operand is allowed into. If
- ;; false, there is no restriction.
+ ;; a list of the names of the SCs that this operand is allowed into.
+ ;; If false, there is no restriction.
(scs nil :type list)
;; Variable that is bound to the load TN allocated for this operand, or to
;; NIL if no load-TN was allocated.
(load-tn (gensym) :type symbol)
- ;; An expression that tests whether to do automatic operand loading.
+ ;; an expression that tests whether to do automatic operand loading
(load t)
- ;; In a wired or restricted temporary this is the SC the TN is to be packed
- ;; in. Null otherwise.
+ ;; In a wired or restricted temporary this is the SC the TN is to be
+ ;; packed in. Null otherwise.
(sc nil :type (or symbol null))
;; If non-null, we are a temp wired to this offset in SC.
(offset nil :type (or unsigned-byte null)))
-
(defprinter (operand-parse)
name
kind
\f
;;;; miscellaneous utilities
-;;; Find the operand or temporary with the specifed Name in the VOP Parse.
-;;; If there is no such operand, signal an error. Also error if the operand
-;;; kind isn't one of the specified Kinds. If Error-P is NIL, just return NIL
-;;; if there is no such operand.
+;;; Find the operand or temporary with the specifed Name in the VOP
+;;; Parse. If there is no such operand, signal an error. Also error if
+;;; the operand kind isn't one of the specified Kinds. If Error-P is
+;;; NIL, just return NIL if there is no such operand.
(defun find-operand (name parse &optional
(kinds '(:argument :result :temporary))
(error-p t))
found))
;;; Get the VOP-Parse structure for NAME or die trying. For all
-;;; meta-compile time uses, the VOP-Parse should be used instead of the
-;;; VOP-Info.
+;;; meta-compile time uses, the VOP-Parse should be used instead of
+;;; the VOP-Info.
(defun vop-parse-or-lose (name)
(the vop-parse
(or (gethash name *backend-parsed-vops*)
(error "~S is not the name of a defined VOP." name))))
-;;; Return a list of let-forms to parse a tn-ref list into a the temps
-;;; specified by the operand-parse structures. More-Operand is the
-;;; Operand-Parse describing any more operand, or NIL if none. Refs is an
-;;; expression that evaluates into the first tn-ref.
+;;; Return a list of LET-forms to parse a TN-REF list into the temps
+;;; specified by the operand-parse structures. MORE-OPERAND is the
+;;; Operand-Parse describing any more operand, or NIL if none. REFS is
+;;; an expression that evaluates into the first tn-ref.
(defun access-operands (operands more-operand refs)
(declare (list operands))
(collect ((res))
(res `(,(operand-parse-name more-operand) ,prev))))
(res)))
-;;; Used with Access-Operands to prevent warnings for TN-Ref temps not used
-;;; by some particular function. It returns the name of the last operand, or
-;;; NIL if Operands is NIL.
+;;; This is used with ACCESS-OPERANDS to prevent warnings for TN-Ref
+;;; temps not used by some particular function. It returns the name of
+;;; the last operand, or NIL if Operands is NIL.
(defun ignore-unreferenced-temps (operands)
(when operands
(operand-parse-temp (car (last operands)))))
\f
;;;; time specs
-;;; Return a time spec describing a time during the evaluation of a VOP,
-;;; used to delimit operand and temporary lifetimes. The representation is a
-;;; cons whose CAR is the number of the evaluation phase and the CDR is the
-;;; sub-phase. The sub-phase is 0 in the :Load and :Save phases.
+;;; Return a time spec describing a time during the evaluation of a
+;;; VOP, used to delimit operand and temporary lifetimes. The
+;;; representation is a cons whose CAR is the number of the evaluation
+;;; phase and the CDR is the sub-phase. The sub-phase is 0 in the
+;;; :LOAD and :SAVE phases.
(defun parse-time-spec (spec)
(let ((dspec (if (atom spec) (list spec 0) spec)))
(unless (and (= (length dspec) 2)
(ash (meta-sc-number-or-lose sc) 1))))
(incf index))
;; KLUDGE: As in the other COERCEs wrapped around with
- ;; MAKE-SPECIALIZABLE-ARRAY results in COMPUTE-REF-ORDERING, this
- ;; coercion could be removed by a sufficiently smart compiler, but I
- ;; dunno whether Python is that smart. It would be good to check this
- ;; and help it if it's not smart enough to remove it for itself.
- ;; However, it's probably not urgent, since the overhead of an extra
- ;; no-op conversion is unlikely to be large compared to consing and
- ;; corresponding GC. -- WHN ca. 19990701
+ ;; MAKE-SPECIALIZABLE-ARRAY results in COMPUTE-REF-ORDERING,
+ ;; this coercion could be removed by a sufficiently smart
+ ;; compiler, but I dunno whether Python is that smart. It
+ ;; would be good to check this and help it if it's not smart
+ ;; enough to remove it for itself. However, it's probably not
+ ;; urgent, since the overhead of an extra no-op conversion is
+ ;; unlikely to be large compared to consing and corresponding
+ ;; GC. -- WHN ca. 19990701
`(coerce ,results '(specializable-vector ,element-type))))))
(defun compute-ref-ordering (parse)
(incf index)))
`(:num-args ,num-args
:num-results ,num-results
- ;; KLUDGE: The (COERCE .. (SPECIALIZABLE-VECTOR ..)) wrapper here
- ;; around the result returned by MAKE-SPECIALIZABLE-ARRAY above was
- ;; of course added to help with cross-compilation. "A sufficiently
- ;; smart compiler" should be able to optimize all this away in the
- ;; final target Lisp, leaving a single MAKE-ARRAY with no subsequent
- ;; coercion. However, I don't know whether Python is that smart. (Can
- ;; it figure out the return type of MAKE-ARRAY? Does it know that
- ;; COERCE can be optimized away if the input type is known to be the
- ;; same as the COERCEd-to type?) At some point it would be good to
- ;; test to see whether this construct is in fact causing run-time
- ;; overhead, and fix it if so. (Some declarations of the types
- ;; returned by MAKE-ARRAY might be enough to fix it.) However, it's
- ;; probably not urgent to fix this, since it's hard to imagine that
- ;; any overhead caused by calling COERCE and letting it decide to
- ;; bail out could be large compared to the cost of consing and GCing
- ;; the vectors in the first place. -- WHN ca. 19990701
+ ;; KLUDGE: The (COERCE .. (SPECIALIZABLE-VECTOR ..)) wrapper
+ ;; here around the result returned by
+ ;; MAKE-SPECIALIZABLE-ARRAY above was of course added to
+ ;; help with cross-compilation. "A sufficiently smart
+ ;; compiler" should be able to optimize all this away in the
+ ;; final target Lisp, leaving a single MAKE-ARRAY with no
+ ;; subsequent coercion. However, I don't know whether Python
+ ;; is that smart. (Can it figure out the return type of
+ ;; MAKE-ARRAY? Does it know that COERCE can be optimized
+ ;; away if the input type is known to be the same as the
+ ;; COERCEd-to type?) At some point it would be good to test
+ ;; to see whether this construct is in fact causing run-time
+ ;; overhead, and fix it if so. (Some declarations of the
+ ;; types returned by MAKE-ARRAY might be enough to fix it.)
+ ;; However, it's probably not urgent to fix this, since it's
+ ;; hard to imagine that any overhead caused by calling
+ ;; COERCE and letting it decide to bail out could be large
+ ;; compared to the cost of consing and GCing the vectors in
+ ;; the first place. -- WHN ca. 19990701
:ref-ordering (coerce ',ordering
'(specializable-vector ,oe-type))
,@(when (targets)
\f
;;;; generator functions
-;;; Return an alist that translates from lists of SCs we can load OP from to
-;;; the move function used for loading those SCs. We quietly ignore
-;;; restrictions to :non-packed (constant) and :unbounded SCs, since we don't
-;;; load into those SCs.
+;;; Return an alist that translates from lists of SCs we can load OP
+;;; from to the move function used for loading those SCs. We quietly
+;;; ignore restrictions to :non-packed (constant) and :unbounded SCs,
+;;; since we don't load into those SCs.
(defun find-move-functions (op load-p)
(collect ((funs))
(dolist (sc-name (operand-parse-scs op))
sc-name load-p (operand-parse-name op))))))
(funs)))
-;;; Return a form to load/save the specified operand when it has a load TN.
-;;; For any given SC that we can load from, there must be a unique load
-;;; function. If all SCs we can load from have the same move function, then we
-;;; just call that when there is a load TN. If there are multiple possible
-;;; move functions, then we dispatch off of the operand TN's type to see which
-;;; move function to use.
+;;; Return a form to load/save the specified operand when it has a
+;;; load TN. For any given SC that we can load from, there must be a
+;;; unique load function. If all SCs we can load from have the same
+;;; move function, then we just call that when there is a load TN. If
+;;; there are multiple possible move functions, then we dispatch off
+;;; of the operand TN's type to see which move function to use.
(defun call-move-function (parse op load-p)
(let ((funs (find-move-functions op load-p))
(load-tn (operand-parse-load-tn op)))
(error "load TN allocated, but no move function?~@
VM definition is inconsistent, recompile and try again.")))))
-;;; Return the TN that we should bind to the operand's var in the generator
-;;; body. In general, this involves evaluating the :LOAD-IF test expression.
+;;; Return the TN that we should bind to the operand's var in the
+;;; generator body. In general, this involves evaluating the :LOAD-IF
+;;; test expression.
(defun decide-to-load (parse op)
(let ((load (operand-parse-load op))
(load-tn (operand-parse-load-tn op))
,@(vop-parse-body parse))
,@(saves))))))
\f
-;;; Given a list of operand specifications as given to Define-VOP, return a
-;;; list of Operand-Parse structures describing the fixed operands, and a
-;;; single Operand-Parse describing any more operand. If we are inheriting a
-;;; VOP, we default attributes to the inherited operand of the same name.
+;;; Given a list of operand specifications as given to DEFINE-VOP,
+;;; return a list of OPERAND-PARSE structures describing the fixed
+;;; operands, and a single OPERAND-PARSE describing any more operand.
+;;; If we are inheriting a VOP, we default attributes to the inherited
+;;; operand of the same name.
(defun parse-operands (parse specs kind)
(declare (list specs)
(type (member :argument :result) kind))
(error "cannot specify :LOAD-IF in a :MORE operand")))))
(values (the list (operands)) more))))
\f
-;;; Parse a temporary specification, entering the Operand-Parse structures
-;;; in the Parse structure.
+;;; Parse a temporary specification, putting the OPERAND-PARSE
+;;; structures in the PARSE structure.
(defun parse-temporary (spec parse)
(declare (list spec)
(type vop-parse parse))
:key #'operand-parse-name))))))
(values))
\f
-;;; Top-level parse function. Clobber Parse to represent the specified options.
+;;; the top-level parse function: clobber PARSE to represent the
+;;; specified options.
(defun parse-define-vop (parse specs)
(declare (type vop-parse parse) (list specs))
(dolist (spec specs)
(setf (vop-parse-translate parse) (rest spec)))
(:guard
(setf (vop-parse-guard parse) (vop-spec-arg spec t)))
+ ;; FIXME: :LTN-POLICY would be a better name for this. It would
+ ;; probably be good to leave it unchanged for a while, though,
+ ;; at least until the first port to some other architecture,
+ ;; since the renaming would be a change to the interface between
(:policy
- (setf (vop-parse-policy parse) (vop-spec-arg spec 'policies)))
+ (setf (vop-parse-ltn-policy parse)
+ (vop-spec-arg spec 'ltn-policy)))
(:save-p
(setf (vop-parse-save-p parse)
(vop-spec-arg spec
(error "unknown option specifier: ~S" (first spec)))))
(values))
\f
-;;;; make costs and restrictions
+;;;; making costs and restrictions
;;; Given an operand, returns two values:
-;;; 1. A SC-vector of the cost for the operand being in that SC, including both
-;;; the costs for move functions and coercion VOPs.
-;;; 2. A SC-vector holding the SC that we load into, for any SC that we can
-;;; directly load from.
+;;; 1. A SC-vector of the cost for the operand being in that SC,
+;;; including both the costs for move functions and coercion VOPs.
+;;; 2. A SC-vector holding the SC that we load into, for any SC
+;;; that we can directly load from.
;;;
-;;; In both vectors, unused entries are NIL. Load-P specifies the direction:
-;;; if true, we are loading, if false we are saving.
+;;; In both vectors, unused entries are NIL. LOAD-P specifies the
+;;; direction: if true, we are loading, if false we are saving.
(defun compute-loading-costs (op load-p)
(declare (type operand-parse op))
(let ((scs (operand-parse-scs op))
(defparameter *no-loads*
(make-array sc-number-limit :initial-element 't))
-;;; Pick off the case of operands with no restrictions.
+;;; Pick off the case of operands with no restrictions.
(defun compute-loading-costs-if-any (op load-p)
(declare (type operand-parse op))
(if (operand-parse-scs op)
(mapcar #'parse-operand-type specs)))
;;; Check the consistency of Op's Sc restrictions with the specified
-;;; primitive-type restriction. :CONSTANT operands have already been filtered
-;;; out, so only :OR and * restrictions are left.
+;;; primitive-type restriction. :CONSTANT operands have already been
+;;; filtered out, so only :OR and * restrictions are left.
;;;
-;;; We check that every representation allowed by the type can be directly
-;;; loaded into some SC in the restriction, and that the type allows every SC
-;;; in the restriction. With *, we require that T satisfy the first test, and
-;;; omit the second.
+;;; We check that every representation allowed by the type can be
+;;; directly loaded into some SC in the restriction, and that the type
+;;; allows every SC in the restriction. With *, we require that T
+;;; satisfy the first test, and omit the second.
(defun check-operand-type-scs (parse op type load-p)
(declare (type vop-parse parse) (type operand-parse op))
(let ((ptypes (if (eq type '*) (list 't) (rest type)))
\f
;;;; function translation stuff
-;;; Return forms to establish this VOP as a IR2 translation template for the
-;;; :Translate functions specified in the VOP-Parse. We also set the
-;;; Predicate attribute for each translated function when the VOP is
-;;; conditional, causing IR1 conversion to ensure that a call to the translated
-;;; is always used in a predicate position.
+;;; Return forms to establish this VOP as a IR2 translation template
+;;; for the :TRANSLATE functions specified in the VOP-Parse. We also
+;;; set the Predicate attribute for each translated function when the
+;;; VOP is conditional, causing IR1 conversion to ensure that a call
+;;; to the translated is always used in a predicate position.
(defun set-up-function-translation (parse n-template)
(declare (type vop-parse parse))
(mapcar #'(lambda (name)
types))
;;; Return a list of forms to use as keyword args to Make-VOP-Info for
-;;; setting up the template argument and result types. Here we make an initial
-;;; dummy Template-Type, since it is awkward to compute the type until the
-;;; template has been made.
+;;; setting up the template argument and result types. Here we make an
+;;; initial dummy Template-Type, since it is awkward to compute the
+;;; type until the template has been made.
(defun make-vop-info-types (parse)
(let* ((more-args (vop-parse-more-args parse))
(all-args (specify-operand-types (vop-parse-arg-types parse)
'((:generator-function . vop-info-generator-function))))
;;; Something to help with inheriting VOP-Info slots. We return a
-;;; keyword/value pair that can be passed to the constructor. Slot is the
-;;; keyword name of the slot, Parse is a form that evaluates to the VOP-Parse
-;;; structure for the VOP inherited. If Parse is NIL, then we do nothing. If
-;;; the Test form evaluates to true, then we return a form that selects the
-;;; named slot from the VOP-Info structure corresponding to Parse. Otherwise,
-;;; we return the Form so that the slot is recomputed.
+;;; keyword/value pair that can be passed to the constructor. SLOT is
+;;; the keyword name of the slot, Parse is a form that evaluates to
+;;; the VOP-Parse structure for the VOP inherited. If PARSE is NIL,
+;;; then we do nothing. If the TEST form evaluates to true, then we
+;;; return a form that selects the named slot from the VOP-Info
+;;; structure corresponding to PARSE. Otherwise, we return the FORM so
+;;; that the slot is recomputed.
(defmacro inherit-vop-info (slot parse test form)
`(if (and ,parse ,test)
(list ,slot `(,',(or (cdr (assoc slot *slot-inherit-alist*))
`#'(lambda () ,(vop-parse-guard parse)))
:note ',(vop-parse-note parse)
:info-arg-count ,(length (vop-parse-info-args parse))
- :policy ',(vop-parse-policy parse)
+ :ltn-policy ',(vop-parse-ltn-policy parse)
:save-p ',(vop-parse-save-p parse)
:move-args ',(vop-parse-move-args parse)
:effects (vop-attributes ,@(vop-parse-effects parse))
(make-generator-function parse)))
:variant (list ,@variant))))
\f
-;;; Parse the syntax into a VOP-Parse structure, and then expand into code
-;;; that creates the appropriate VOP-Info structure at load time. We implement
-;;; inheritance by copying the VOP-Parse structure for the inherited structure.
+;;; Parse the syntax into a VOP-Parse structure, and then expand into
+;;; code that creates the appropriate VOP-Info structure at load time.
+;;; We implement inheritance by copying the VOP-Parse structure for
+;;; the inherited structure.
(def!macro define-vop ((name &optional inherits) &rest specs)
#!+sb-doc
"Define-VOP (Name [Inherits]) Spec*
frame."
(check-type name symbol)
- (let* ((iparse (when inherits
- (vop-parse-or-lose inherits)))
+ (let* ((inherited-parse (when inherits
+ (vop-parse-or-lose inherits)))
(parse (if inherits
- (copy-vop-parse iparse)
+ (copy-vop-parse inherited-parse)
(make-vop-parse)))
(n-res (gensym)))
(setf (vop-parse-name parse) name)
(setf (gethash ',name *backend-parsed-vops*)
',parse))
- (let ((,n-res ,(set-up-vop-info iparse parse)))
+ (let ((,n-res ,(set-up-vop-info inherited-parse parse)))
(setf (gethash ',name *backend-template-names*) ,n-res)
(setf (template-type ,n-res)
(specifier-type (template-type-specifier ,n-res)))
;;;; emission macros
;;; Return code to make a list of VOP arguments or results, linked by
-;;; TN-Ref-Across. The first value is code, the second value is LET* forms,
-;;; and the third value is a variable that evaluates to the head of the list,
-;;; or NIL if there are no operands. Fixed is a list of forms that evaluate to
-;;; TNs for the fixed operands. TN-Refs will be made for these operands
-;;; according using the specified value of Write-P. More is an expression that
-;;; evaluates to a list of TN-Refs that will be made the tail of the list. If
-;;; it is constant NIL, then we don't bother to set the tail.
+;;; TN-Ref-Across. The first value is code, the second value is LET*
+;;; forms, and the third value is a variable that evaluates to the
+;;; head of the list, or NIL if there are no operands. Fixed is a list
+;;; of forms that evaluate to TNs for the fixed operands. TN-Refs will
+;;; be made for these operands according using the specified value of
+;;; Write-P. More is an expression that evaluates to a list of TN-Refs
+;;; that will be made the tail of the list. If it is constant NIL,
+;;; then we don't bother to set the tail.
(defun make-operand-list (fixed more write-p)
(collect ((forms)
(binds))
;; called for, but it believes it has proven that the check won't
;; be done for policy reasons or because a safe implementation
;; will be used. In the latter case, LTN must ensure that a safe
- ;; implementation *is* be used.
+ ;; implementation *is* used.
;;
;; :ERROR
;; There is a compile-time type error in some use of this
(:constructor make-combination (fun))))
(defprinter (combination)
(fun :prin1 (continuation-use fun))
- (args :prin1 (mapcar #'(lambda (x)
- (if x
- (continuation-use x)
- "<deleted>"))
+ (args :prin1 (mapcar (lambda (x)
+ (if x
+ (continuation-use x)
+ "<deleted>"))
args)))
-;;; An MV-Combination is to Multiple-Value-Call as a Combination is to
-;;; Funcall. This is used to implement all the multiple-value
+;;; An MV-COMBINATION is to MULTIPLE-VALUE-CALL as a COMBINATION is to
+;;; FUNCALL. This is used to implement all the multiple-value
;;; receiving forms.
(defstruct (mv-combination (:include basic-combination)
(:constructor make-mv-combination (fun))))
;; 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,
(binds (mapcar (lambda (name)
`(,name (policy-quality ,n-policy ',name)))
used-qualities)))
- (/show "in compile-time POLICY" expr binds)
`(let* ((,n-policy (lexenv-policy ,(if node
`(node-lexenv ,node)
'*lexenv*)))
,@binds)
- ;;(/show "in run-time POLICY" ,@used-qualities)
,expr)))
(values))
\f
-;;; Called when we discover that the stack-top unknown-values continuation
-;;; at the end of Block1 is different from that at the start of Block2 (its
-;;; successor.)
+;;; This is called when we discover that the stack-top unknown-values
+;;; continuation at the end of BLOCK1 is different from that at the
+;;; start of BLOCK2 (its successor).
;;;
-;;; We insert a call to a funny function in a new cleanup block introduced
-;;; between Block1 and Block2. Since control analysis and LTN have already
-;;; run, we must do make an IR2 block, then do ADD-TO-EMIT-ORDER and
-;;; LTN-ANALYZE-BLOCK on the new block. The new block is inserted after Block1
-;;; in the emit order.
+;;; We insert a call to a funny function in a new cleanup block
+;;; introduced between BLOCK1 and BLOCK2. Since control analysis and
+;;; LTN have already run, we must do make an IR2 block, then do
+;;; ADD-TO-EMIT-ORDER and LTN-ANALYZE-BELATED-BLOCK on the new block.
+;;; The new block is inserted after BLOCK1 in the emit order.
;;;
-;;; If the control transfer between Block1 and Block2 represents a
-;;; tail-recursive return (:Deleted IR2-continuation) or a non-local exit, then
-;;; the cleanup code will never actually be executed. It doesn't seem to be
-;;; worth the risk of trying to optimize this, since this rarely happens and
-;;; wastes only space.
+;;; If the control transfer between BLOCK1 and BLOCK2 represents a
+;;; tail-recursive return (:DELETED IR2-continuation) or a non-local
+;;; exit, then the cleanup code will never actually be executed. It
+;;; doesn't seem to be worth the risk of trying to optimize this,
+;;; since this rarely happens and wastes only space.
(defun discard-unused-values (block1 block2)
(declare (type cblock block1 block2))
(let* ((block1-stack (ir2-block-end-stack (block-info block1)))
(2block (make-ir2-block block)))
(setf (block-info block) 2block)
(add-to-emit-order 2block (block-info block1))
- (ltn-analyze-block block)))
+ (ltn-analyze-belated-block block)))
(values))
\f
(deftype local-tn-vector () `(simple-vector ,local-tn-limit))
(deftype local-tn-bit-vector () `(simple-bit-vector ,local-tn-limit))
-;;; Type of an SC number.
+;;; type of an SC number
(deftype sc-number () `(integer 0 (,sc-number-limit)))
-;;; Types for vectors indexed by SC numbers.
+;;; types for vectors indexed by SC numbers
(deftype sc-vector () `(simple-vector ,sc-number-limit))
(deftype sc-bit-vector () `(simple-bit-vector ,sc-number-limit))
-;;; The different policies we can use to determine the coding strategy.
-(deftype policies ()
+;;; the different policies we can use to determine the coding strategy
+(deftype ltn-policy ()
'(member :safe :small :fast :fast-safe))
\f
;;;; PRIMITIVE-TYPEs
;;; a known function.
(def!struct (template (:constructor nil)
#-sb-xc-host (:pure t))
- ;; The symbol name of this VOP. This is used when printing the VOP
+ ;; the symbol name of this VOP. This is used when printing the VOP
;; and is also used to provide a handle for definition and
;; translation.
(name nil :type symbol)
- ;; A Function-Type describing the arg/result type restrictions. We
- ;; compute this from the Primitive-Type restrictions to make life
- ;; easier for IR1 phases that need to anticipate LTN's template
- ;; selection.
+ ;; the arg/result type restrictions. We compute this from the
+ ;; PRIMITIVE-TYPE restrictions to make life easier for IR1 phases
+ ;; that need to anticipate LTN's template selection.
(type (required-argument) :type function-type)
- ;; Lists of restrictions on the argument and result types. A
+ ;; lists of restrictions on the argument and result types. A
;; restriction may take several forms:
;; -- The restriction * is no restriction at all.
;; -- A restriction (:OR <primitive-type>*) means that the operand
;; the type tested by the predicate, used when we want to represent
;; the type constraint as a Lisp function type.
;;
- ;; If Result-Types is :Conditional, then this is an IF-xxx style
+ ;; If RESULT-TYPES is :CONDITIONAL, then this is an IF-FOO style
;; conditional that yeilds its result as a control transfer. The
;; emit function takes two info arguments: the target label and a
;; boolean flag indicating whether to negate the sense of the test.
(arg-types nil :type list)
(result-types nil :type (or list (member :conditional)))
- ;; The primitive type restriction applied to each extra argument or
+ ;; the primitive type restriction applied to each extra argument or
;; result following the fixed operands. If NIL, no extra
;; args/results are allowed. Otherwise, either * or a (:OR ...) list
;; as described for the {ARG,RESULT}-TYPES.
;; conditionally compile for different target hardware
;; configuarations (e.g. FP hardware.)
(guard nil :type (or function null))
- ;; The policy under which this template is the best translation.
+ ;; the policy under which this template is the best translation.
;; Note that LTN might use this template under other policies if it
- ;; can't figure our anything better to do.
- (policy (required-argument) :type policies)
- ;; The base cost for this template, given optimistic assumptions
+ ;; can't figure out anything better to do.
+ (ltn-policy (required-argument) :type ltn-policy)
+ ;; the base cost for this template, given optimistic assumptions
;; such as no operand loading, etc.
(cost (required-argument) :type index)
- ;; If true, then a short noun-like phrase describing what this VOP
- ;; "does", i.e. the implementation strategy. This is for use in
- ;; efficiency notes.
+ ;; If true, then this is a short noun-like phrase describing what
+ ;; this VOP "does", i.e. the implementation strategy. This is for
+ ;; use in efficiency notes.
(note nil :type (or string null))
;; The number of trailing arguments to VOP or %PRIMITIVE that we
;; bundle into a list and pass into the emit function. This provides
;; a way to pass uninterpreted stuff directly to the code generator.
(info-arg-count 0 :type index)
- ;; A function that emits the VOPs for this template. Arguments:
+ ;; a function that emits the VOPs for this template. Arguments:
;; 1] Node for source context.
;; 2] IR2-Block that we place the VOP in.
;; 3] This structure.
result-types
(more-args-type :test more-args-type :prin1 more-args-type)
(more-results-type :test more-results-type :prin1 more-results-type)
- policy
+ ltn-policy
cost
(note :test note)
(info-arg-count :test (not (zerop info-arg-count))))
(def!struct (vop-info
(:include template)
(:make-load-form-fun ignore-it))
- ;; Side-effects of this VOP and side-effects that affect the value
- ;; of this VOP.
+ ;; side-effects of this VOP and side-effects that affect the value
+ ;; of this VOP
(effects (required-argument) :type attributes)
(affected (required-argument) :type attributes)
;; If true, causes special casing of TNs live after this VOP that
;; -- If :Compute-Only, just compute the save set, don't do any saving.
;; This is used to get the live variables for debug info.
(save-p nil :type (member t nil :force-to-stack :compute-only))
- ;; Info for automatic emission of move-arg VOPs by representation
+ ;; info for automatic emission of move-arg VOPs by representation
;; selection. If NIL, then do nothing special. If non-null, then
;; there must be a more arg. Each more arg is moved to its passing
;; location using the appropriate representation-specific
;; :KNOWN-RETURN
;; If needed, the old NFP is computed using COMPUTE-OLD-NFP.
(move-args nil :type (member nil :full-call :local-call :known-return))
- ;; A list of sc-vectors representing the loading costs of each fixed
- ;; argument and result.
+ ;; a list of sc-vectors representing the loading costs of each fixed
+ ;; argument and result
(arg-costs nil :type list)
(result-costs nil :type list)
- ;; If true, sc-vectors representing the loading costs for any more
- ;; args and results.
+ ;; if true, SC-VECTORs representing the loading costs for any more
+ ;; args and results
(more-arg-costs nil :type (or sc-vector null))
(more-result-costs nil :type (or sc-vector null))
- ;; Lists of sc-vectors mapping each SC to the SCs that we can load
+ ;; lists of SC-VECTORs mapping each SC to the SCs that we can load
;; into. If a SC is directly acceptable to the VOP, then the entry
;; is T. Otherwise, it is a list of the SC numbers of all the SCs
;; that we can load into. This list will be empty if there is no
;; operand SC restriction.
(arg-load-scs nil :type list)
(result-load-scs nil :type list)
- ;; If true, a function that is called with the VOP to do operand
+ ;; if true, a function that is called with the VOP to do operand
;; targeting. This is done by modifiying the TN-Ref-Target slots in
;; the TN-Refs so that they point to other TN-Refs in the same VOP.
(target-function nil :type (or null function))
- ;; A function that emits assembly code for a use of this VOP when it
+ ;; a function that emits assembly code for a use of this VOP when it
;; is called with the VOP structure. Null if this VOP has no
;; specified generator (i.e. it exists only to be inherited by other
;; VOPs.)
(generator-function nil :type (or function null))
- ;; A list of things that are used to parameterize an inherited
+ ;; a list of things that are used to parameterize an inherited
;; generator. This allows the same generator function to be used for
;; a group of VOPs with similar implementations.
(variant nil :type list)
- ;; The number of arguments and results. Each regular arg/result
+ ;; the number of arguments and results. Each regular arg/result
;; counts as one, and all the more args/results together count as 1.
(num-args 0 :type index)
(num-results 0 :type index)
- ;; Vector of the temporaries the vop needs. See emit-generic-vop in
- ;; vmdef for information on how the temps are encoded.
- ;;
- ;; (The SB-XC-HOST conditionalization on the type is there because
- ;; it's difficult to dump specialized arrays portably, so on the
- ;; cross-compilation host we punt by using unspecialized arrays
- ;; instead.)
+ ;; a vector of the temporaries the vop needs. See EMIT-GENERIC-VOP
+ ;; in vmdef for information on how the temps are encoded.
(temps nil :type (or null (specializable-vector (unsigned-byte 16))))
- ;; The order all the refs for this vop should be put in. Each
+ ;; the order all the refs for this vop should be put in. Each
;; operand is assigned a number in the following ordering: args,
;; more-args, results, more-results, temps This vector represents
;; the order the operands should be put into in the next-ref link.
- ;;
- ;; (The SB-XC-HOST conditionalization on the type is there because
- ;; it's difficult to dump specialized arrays portably, so on the
- ;; cross-compilation host we punt by using unspecialized arrays
- ;; instead.)
(ref-ordering nil :type (or null (specializable-vector (unsigned-byte 8))))
- ;; Array of the various targets that should be done. Each element
+ ;; a vector of the various targets that should be done. Each element
;; encodes the source ref (shifted 8) and the dest ref index.
(targets nil :type (or null (specializable-vector (unsigned-byte 16)))))
\f
(inst and result #x0000ffff)
(inst and temp #x0000ffff)
(inst add result temp)))
-
-
\f
;;;; binary conditional VOPs
(:result-types single-float)
(:generator 5
(cond ((zerop (tn-offset value))
- ;; Value is in ST0
+ ;; Value is in ST0.
(inst fst (make-ea :dword :base object :index index :scale 1
:disp (- (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(:result-types single-float)
(:generator 4
(cond ((zerop (tn-offset value))
- ;; Value is in ST0
+ ;; Value is in ST0.
(inst fst (make-ea :dword :base object
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(:result-types double-float)
(:generator 20
(cond ((zerop (tn-offset value))
- ;; Value is in ST0
+ ;; Value is in ST0.
(inst fstd (make-ea :dword :base object :index index :scale 2
:disp (- (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(:result-types double-float)
(:generator 19
(cond ((zerop (tn-offset value))
- ;; Value is in ST0
+ ;; Value is in ST0.
(inst fstd (make-ea :dword :base object
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
;; temp = 3 * index
(inst lea temp (make-ea :dword :base index :index index :scale 2))
(cond ((zerop (tn-offset value))
- ;; Value is in ST0
+ ;; Value is in ST0.
(store-long-float
(make-ea :dword :base object :index temp :scale 1
:disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
(:result-types long-float)
(:generator 19
(cond ((zerop (tn-offset value))
- ;; Value is in ST0
+ ;; Value is in ST0.
(store-long-float (make-ea :dword :base object
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(let ((value-real (complex-single-reg-real-tn value))
(result-real (complex-single-reg-real-tn result)))
(cond ((zerop (tn-offset value-real))
- ;; Value is in ST0
+ ;; Value is in ST0.
(inst fst (make-ea :dword :base object
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(let ((value-real (complex-double-reg-real-tn value))
(result-real (complex-double-reg-real-tn result)))
(cond ((zerop (tn-offset value-real))
- ;; Value is in ST0
+ ;; Value is in ST0.
(inst fstd (make-ea :dword :base object :index index :scale 4
:disp (- (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(let ((value-real (complex-double-reg-real-tn value))
(result-real (complex-double-reg-real-tn result)))
(cond ((zerop (tn-offset value-real))
- ;; Value is in ST0
+ ;; Value is in ST0.
(inst fstd (make-ea :dword :base object
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(let ((value-real (complex-long-reg-real-tn value))
(result-real (complex-long-reg-real-tn result)))
(cond ((zerop (tn-offset value-real))
- ;; Value is in ST0
+ ;; Value is in ST0.
(store-long-float
(make-ea :dword :base object :index temp :scale 2
:disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
(let ((value-real (complex-long-reg-real-tn value))
(result-real (complex-long-reg-real-tn result)))
(cond ((zerop (tn-offset value-real))
- ;; Value is in ST0
+ ;; Value is in ST0.
(store-long-float
(make-ea :dword :base object
:disp (- (+ (* sb!vm:vector-data-offset
(unless (location= value-imag result-imag)
(inst fstd result-imag))
(inst fxch value-imag))))
-
\f
-;;;; dtc expanded and fixed the following:
-
;;; unsigned-byte-8
(define-vop (data-vector-ref/simple-array-unsigned-byte-8)
symbol)))))
(error "~S is not a legal structure class name." symbol)))
\f
-(defun method-function-returning-nil (args next-methods)
- (declare (ignore args next-methods))
- nil)
-
-(defun method-function-returning-t (args next-methods)
- (declare (ignore args next-methods))
- t)
-
(defun make-class-predicate (class name)
(let* ((gf (ensure-generic-function name))
(mlist (if (eq *boot-state* 'complete)
(early-gf-methods gf))))
(unless mlist
(unless (eq class *the-class-t*)
- (let* ((default-method-function #'method-function-returning-nil)
+ (let* ((default-method-function #'constantly-nil)
(default-method-initargs (list :function
default-method-function))
(default-method (make-a-method 'standard-method
(setf (method-function-get default-method-function :constant-value)
nil)
(add-method gf default-method)))
- (let* ((class-method-function #'method-function-returning-t)
+ (let* ((class-method-function #'constantly-t)
(class-method-initargs (list :function
class-method-function))
(class-method (make-a-method 'standard-method
;;; FIXME: It's not clear that this adds value any more. Couldn't
;;; we just use EVAL-WHEN?
(defun make-top-level-form (name times form)
- (flet ((definition-name ()
- (if (and (listp name)
- (memq (car name)
- '(defmethod defclass class
- method method-combination)))
- (format nil "~A~{ ~S~}"
- (capitalize-words (car name) ()) (cdr name))
- (format nil "~S" name))))
- ;; FIXME: It appears that we're just consing up a string and then
- ;; throwing it away?!
- (definition-name)
- (if (or (member 'compile times)
- (member ':compile-toplevel times))
- `(eval-when ,times ,form)
- form)))
+ (if (or (member 'compile times)
+ (member ':compile-toplevel times))
+ `(eval-when ,times ,form)
+ form))
(defun make-progn (&rest forms)
(let ((progn-form nil))
(declare (special *initfunctions*))
(cond ((or (eq initform 't)
(equal initform ''t))
- '(function true))
+ '(function constantly-t))
((or (eq initform 'nil)
(equal initform ''nil))
- '(function false))
+ '(function constantly-nil))
((or (eql initform '0)
(equal initform ''0))
- '(function zero))
+ '(function constantly-0))
(t
(let ((entry (assoc initform *initfunctions* :test #'equal)))
(unless entry
(slots nil))
;;; Both of these operations "work" on structures, which allows the above
-;;; weakening of std-instance-p.
+;;; weakening of STD-INSTANCE-P.
(defmacro std-instance-slots (x) `(sb-kernel:%instance-ref ,x 1))
(defmacro std-instance-wrapper (x) `(sb-kernel:%instance-layout ,x))
;;; implementations, but I will leave it to the compiler to optimize
;;; into calls to them.
;;;
-;;; FIXME: MEMQ, ASSQ, and DELQ are already defined in SBCL, and we should
-;;; use those. POSQ and NEQ aren't defined in SBCL, and are used too often
-;;; in PCL to make it appealing to hand expand all uses and then delete
-;;; the macros, so they should be boosted up to SBCL to stand by MEMQ,
-;;; ASSQ, and DELQ.
+;;; FIXME: MEMQ, ASSQ, and DELQ are already defined in SBCL, and we
+;;; should use those definitions. POSQ and NEQ aren't defined in SBCL,
+;;; and are used too often in PCL to make it appealing to hand expand
+;;; all uses and then delete the macros, so they should be boosted up
+;;; to SB-INT to stand by MEMQ, ASSQ, and DELQ.
(defmacro memq (item list) `(member ,item ,list :test #'eq))
(defmacro assq (item list) `(assoc ,item ,list :test #'eq))
(defmacro delq (item list) `(delete ,item ,list :test #'eq))
(defmacro posq (item list) `(position ,item ,list :test #'eq))
(defmacro neq (x y) `(not (eq ,x ,y)))
-
-;;; FIXME: Rename these to CONSTANTLY-T, CONSTANTLY-NIL, and
-;;; CONSTANTLY-0, and boost them up to SB-INT.
-(defun true (&rest ignore) (declare (ignore ignore)) t)
-(defun false (&rest ignore) (declare (ignore ignore)) nil)
-(defun zero (&rest ignore) (declare (ignore ignore)) 0)
+;;; FIXME: CONSTANTLY-FOO should be boosted up to SB-INT too.
+(macrolet ((def-constantly-fun (name constant-expr)
+ `(setf (symbol-function ',name)
+ (constantly ,constant-expr))))
+ (def-constantly-fun constantly-t t)
+ (def-constantly-fun constantly-nil nil)
+ (def-constantly-fun constantly-0 0))
;;; comment from original CMU CL PCL: ONCE-ONLY does the same thing as
;;; it does in zetalisp. I should have just lifted it from there but I
(setq ,var (pop .dolist-carefully.))
,@body)
(,improper-list-handler)))))
-
-;;; FIXME: Do we really need this? It seems to be used only
-;;; for class names. Why not just the default ALL-CAPS?
-(defun capitalize-words (string &optional (dashes-p t))
- (let ((string (copy-seq (string string))))
- (declare (string string))
- (do* ((flag t flag)
- (length (length string) length)
- (char nil char)
- (i 0 (+ i 1)))
- ((= i length) string)
- (setq char (elt string i))
- (cond ((both-case-p char)
- (if flag
- (and (setq flag (lower-case-p char))
- (setf (elt string i) (char-upcase char)))
- (and (not flag) (setf (elt string i) (char-downcase char))))
- (setq flag nil))
- ((char-equal char #\-)
- (setq flag t)
- (unless dashes-p (setf (elt string i) #\space)))
- (t (setq flag nil))))))
\f
;;;; FIND-CLASS
;;;;
-;;;; This is documented in the CLOS specification.
-;;;; KLUDGE: Except that SBCL deviates from the spec by having CL:FIND-CLASS
-;;;; distinct from PCL:FIND-CLASS, alas. -- WHN 19991203
+;;;; This is documented in the CLOS specification. FIXME: Except that
+;;;; SBCL deviates from the spec by having CL:FIND-CLASS distinct from
+;;;; PCL:FIND-CLASS, alas.
(defvar *find-class* (make-hash-table :test 'eq))
-(defun function-returning-nil (x)
- (declare (ignore x))
- nil)
-
-(defun function-returning-t (x)
- (declare (ignore x))
- t)
-
(defmacro find-class-cell-class (cell)
`(car ,cell))
(defmacro make-find-class-cell (class-name)
(declare (ignore class-name))
- '(list* nil #'function-returning-nil nil))
+ '(list* nil #'constantly-nil nil))
(defun find-class-cell (symbol &optional dont-create-p)
(or (gethash symbol *find-class*)
class))
(defmethod class-predicate-name ((class t))
- 'function-returning-nil)
+ 'constantly-nil)
(defun ensure-class-values (class args)
(let* ((initargs (copy-list args))
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.9.14"
+"0.6.9.16"
projects / sbcl.git / commitdiff