;;;; files for more information.
(in-package "SB!C")
-
-(file-comment
- "$Header$")
\f
;;;; storage class and storage base definition
-;;; Enter the basic structure at meta-compile time, and then fill in the
-;;; missing slots at load time.
+;;; Define a storage base having the specified NAME. KIND may be :FINITE,
+;;; :UNBOUNDED or :NON-PACKED. The following keywords are legal:
+;;; :SIZE specifies the number of locations in a :FINITE SB or
+;;; the initial size of an :UNBOUNDED SB.
+;;;
+;;; We enter the basic structure at meta-compile time, and then fill
+;;; in the missing slots at load time.
(defmacro define-storage-base (name kind &key size)
- #!+sb-doc
- "Define-Storage-Base Name Kind {Key Value}*
- Define a storage base having the specified Name. Kind may be :Finite,
- :Unbounded or :Non-Packed. The following keywords are legal:
- :Size <Size>
- Specify the number of locations in a :Finite SB or the initial size of a
- :Unbounded SB."
-
- ;; FIXME: Replace with DECLARE.
- (check-type name symbol)
- (check-type kind (member :finite :unbounded :non-packed))
+ (declare (type symbol name))
+ (declare (type (member :finite :unbounded :non-packed) kind))
;; SIZE is either mandatory or forbidden.
(ecase kind
(error "A size specification is meaningless in a ~S SB." kind)))
((:finite :unbounded)
(unless size (error "Size is not specified in a ~S SB." kind))
- (check-type size unsigned-byte)))
+ (aver (typep size 'unsigned-byte))))
(let ((res (if (eq kind :non-packed)
(make-sb :name name :kind kind)
(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")
(/show0 "finished with DEFINE-STORAGE-BASE expansion")
',name)))
+;;; Define a storage class NAME that uses the named Storage-Base.
+;;; NUMBER is a small, non-negative integer that is used as an alias.
+;;; The following keywords are defined:
+;;;
+;;; :ELEMENT-SIZE Size
+;;; The size of objects in this SC in whatever units the SB uses.
+;;; This defaults to 1.
+;;;
+;;; :ALIGNMENT Size
+;;; The alignment restrictions for this SC. TNs will only be
+;;; allocated at offsets that are an even multiple of this number.
+;;; This defaults to 1.
+;;;
+;;; :LOCATIONS (Location*)
+;;; If the SB is :FINITE, then this is a list of the offsets within
+;;; the SB that are in this SC.
+;;;
+;;; :RESERVE-LOCATIONS (Location*)
+;;; A subset of the Locations that the register allocator should try to
+;;; reserve for operand loading (instead of to hold variable values.)
+;;;
+;;; :SAVE-P {T | NIL}
+;;; If T, then values stored in this SC must be saved in one of the
+;;; non-save-p :ALTERNATE-SCs across calls.
+;;;
+;;; :ALTERNATE-SCS (SC*)
+;;; Indicates other SCs that can be used to hold values from this SC across
+;;; calls or when storage in this SC is exhausted. The SCs should be
+;;; specified in order of decreasing \"goodness\". There must be at least
+;;; one SC in an unbounded SB, unless this SC is only used for restricted or
+;;; wired TNs.
+;;;
+;;; :CONSTANT-SCS (SC*)
+;;; A list of the names of all the constant SCs that can be loaded into this
+;;; SC by a move function.
(defmacro define-storage-class (name number sb-name &key (element-size '1)
(alignment '1) locations reserve-locations
save-p alternate-scs constant-scs)
- #!+sb-doc
- "Define-Storage-Class Name Number Storage-Base {Key Value}*
- Define a storage class Name that uses the named Storage-Base. Number is a
- small, non-negative integer that is used as an alias. The following
- keywords are defined:
-
- :Element-Size Size
- The size of objects in this SC in whatever units the SB uses. This
- defaults to 1.
-
- :Alignment Size
- The alignment restrictions for this SC. TNs will only be allocated at
- offsets that are an even multiple of this number. Defaults to 1.
-
- :Locations (Location*)
- If the SB is :Finite, then this is a list of the offsets within the SB
- that are in this SC.
-
- :Reserve-Locations (Location*)
- A subset of the Locations that the register allocator should try to
- reserve for operand loading (instead of to hold variable values.)
-
- :Save-P {T | NIL}
- If T, then values stored in this SC must be saved in one of the
- non-save-p :Alternate-SCs across calls.
-
- :Alternate-SCs (SC*)
- Indicates other SCs that can be used to hold values from this SC across
- calls or when storage in this SC is exhausted. The SCs should be
- specified in order of decreasing \"goodness\". There must be at least
- one SC in an unbounded SB, unless this SC is only used for restricted or
- wired TNs.
-
- :Constant-SCs (SC*)
- A list of the names of all the constant SCs that can be loaded into this
- SC by a move function."
-
- (check-type name symbol)
- (check-type number sc-number)
- (check-type sb-name symbol)
- (check-type locations list)
- (check-type reserve-locations list)
- (check-type save-p boolean)
- (check-type alternate-scs list)
- (check-type constant-scs list)
+ (declare (type symbol name))
+ (declare (type sc-number number))
+ (declare (type symbol sb-name))
+ (declare (type list locations reserve-locations alternate-scs constant-scs))
+ (declare (type boolean save-p))
(unless (= (logcount alignment) 1)
- (error "alignment not a power of two: ~D" alignment))
+ (error "alignment not a power of two: ~W" alignment))
(let ((sb (meta-sb-or-lose sb-name)))
(if (eq (sb-kind sb) :finite)
(let ((size (sb-size sb))
(element-size (eval element-size)))
- (check-type element-size unsigned-byte)
+ (declare (type unsigned-byte element-size))
(dolist (el locations)
- (check-type el unsigned-byte)
+ (declare (type unsigned-byte el))
(unless (<= 1 (+ el element-size) size)
- (error "SC element ~D out of bounds for ~S" el sb))))
+ (error "SC element ~W out of bounds for ~S" el sb))))
(when locations
(error ":LOCATIONS is meaningless in a ~S SB." (sb-kind sb))))
(if (or (eq sb-name 'non-descriptor-stack)
(find 'non-descriptor-stack
(mapcar #'meta-sc-or-lose alternate-scs)
- :key #'(lambda (x)
- (sb-name (sc-sb x)))))
+ :key (lambda (x)
+ (sb-name (sc-sb x)))))
t nil)))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(let ((old (svref *backend-sc-numbers* ',number)))
(when (and old (not (eq (sc-name old) ',name)))
- (warn "redefining SC number ~D from ~S to ~S" ',number
+ (warn "redefining SC number ~W from ~S to ~S" ',number
(sc-name old) ',name)))
(setf (svref *backend-sc-numbers* ',number)
(let ((,to-sc-var (meta-sc-or-lose to)))
,@body))))))
-(defmacro define-move-function ((name cost) lambda-list scs &body body)
- #!+sb-doc
- "Define-Move-Function (Name Cost) lambda-list ({(From-SC*) (To-SC*)}*) form*
- Define the function Name and note it as the function used for moving operands
- from the From-SCs to the To-SCs. Cost is the cost of this move operation.
- The function is called with three arguments: the VOP (for context), and the
- source and destination TNs. An ASSEMBLE form is wrapped around the body.
- All uses of DEFINE-MOVE-FUNCTION should be compiled before any uses of
- DEFINE-VOP."
+;;; Define the function NAME and note it as the function used for
+;;; moving operands from the From-SCs to the To-SCs. Cost is the cost
+;;; of this move operation. The function is called with three
+;;; arguments: the VOP (for context), and the source and destination
+;;; TNs. An ASSEMBLE form is wrapped around the body. All uses of
+;;; DEFINE-MOVE-FUN should be compiled before any uses of
+;;; DEFINE-VOP.
+(defmacro define-move-fun ((name cost) lambda-list scs &body body)
+ (declare (type index cost))
(when (or (oddp (length scs)) (null scs))
(error "malformed SCs spec: ~S" scs))
- (check-type cost index)
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(do-sc-pairs (from-sc to-sc ',scs)
(unless (eq from-sc to-sc)
(let ((num (sc-number from-sc)))
- (setf (svref (sc-move-functions to-sc) num) ',name)
+ (setf (svref (sc-move-funs to-sc) num) ',name)
(setf (svref (sc-load-costs to-sc) num) ',cost)))))
(defun ,name ,lambda-list
(sb!assem:assemble (*code-segment* ,(first lambda-list))
,@body))))
-(defconstant sc-vop-slots '((:move . sc-move-vops)
- (:move-argument . sc-move-arg-vops)))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *sc-vop-slots*
+ '((:move . sc-move-vops)
+ (:move-arg . sc-move-arg-vops))))
+;;; Make NAME be the VOP used to move values in the specified FROM-SCs
+;;; to the representation of the TO-SCs of each SC pair in SCS.
+;;;
+;;; If KIND is :MOVE-ARG, then the VOP takes an extra argument,
+;;; which is the frame pointer of the frame to move into.
+;;;
;;; We record the VOP and costs for all SCs that we can move between
;;; (including implicit loading).
(defmacro define-move-vop (name kind &rest scs)
- #!+sb-doc
- "Define-Move-VOP Name {:Move | :Move-Argument} {(From-SC*) (To-SC*)}*
- Make Name be the VOP used to move values in the specified From-SCs to the
- representation of the To-SCs. If kind is :Move-Argument, then the VOP takes
- an extra argument, which is the frame pointer of the frame to move into."
(when (or (oddp (length scs)) (null scs))
(error "malformed SCs spec: ~S" scs))
- (let ((accessor (or (cdr (assoc kind sc-vop-slots))
+ (let ((accessor (or (cdr (assoc kind *sc-vop-slots*))
(error "unknown kind ~S" kind))))
`(progn
,@(when (eq kind :move)
(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.
-(defmacro def-primitive-type (name scs &key (type name))
- #!+sb-doc
- "Def-Primitive-Type Name (SC*) {Key Value}*
- Define a primitive type Name. Each SC specifies a Storage Class that values
- of this type may be allocated in. The following keyword options are
- defined:
-
- :Type
- The type descriptor for the Lisp type that is equivalent to this type
- (defaults to Name.)"
- (check-type name symbol)
- (check-type scs list)
- (let ((scns (mapcar #'meta-sc-number-or-lose scs))
- (get-type `(specifier-type ',type)))
+;;; Define a primitive type NAME. Each SCS entry specifies a storage
+;;; class that values of this type may be allocated in. TYPE is the
+;;; type descriptor for the Lisp type that is equivalent to this type.
+(defmacro !def-primitive-type (name scs &key (type name))
+ (declare (type symbol name) (type list scs))
+ (let ((scns (mapcar #'meta-sc-number-or-lose scs)))
`(progn
+ (/show0 "doing !DEF-PRIMITIVE-TYPE, NAME=..")
+ (/primitive-print ,(symbol-name name))
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(setf (gethash ',name *backend-meta-primitive-type-names*)
(make-primitive-type :name ',name
:scs ',scns
- :type ,get-type)))
- ,(once-only ((n-old `(gethash ',name *backend-primitive-type-names*))
- (n-type get-type))
+ :specifier ',type)))
+ ,(once-only ((n-old `(gethash ',name *backend-primitive-type-names*)))
`(progn
+ ;; If the PRIMITIVE-TYPE structure already exists, we
+ ;; destructively modify it so that existing references in
+ ;; templates won't be invalidated. FIXME: This should no
+ ;; longer be an issue in SBCL, since we don't try to do
+ ;; serious surgery on ourselves. Probably this should
+ ;; just become an assertion that N-OLD is NIL, so that we
+ ;; don't have to try to maintain the correctness of the
+ ;; never-ordinarily-used clause.
+ (/show0 "in !DEF-PRIMITIVE-TYPE, about to COND")
(cond (,n-old
+ (/show0 "in ,N-OLD clause of COND")
(setf (primitive-type-scs ,n-old) ',scns)
- (setf (primitive-type-type ,n-old) ,n-type))
+ (setf (primitive-type-specifier ,n-old) ',type))
(t
+ (/show0 "in T clause of COND")
(setf (gethash ',name *backend-primitive-type-names*)
(make-primitive-type :name ',name
:scs ',scns
- :type ,n-type))))
+ :specifier ',type))))
+ (/show0 "done with !DEF-PRIMITIVE-TYPE")
',name)))))
-;;; Just record the translation.
-(defmacro def-primitive-type-alias (name result)
- #!+sb-doc
- "DEF-PRIMITIVE-TYPE-ALIAS Name Result
- Define name to be an alias for Result in VOP operand type restrictions."
+;;; Define NAME to be an alias for RESULT in VOP operand type restrictions.
+(defmacro !def-primitive-type-alias (name result)
+ ;; Just record the translation.
`(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (gethash ',name *backend-primitive-type-aliases*) ',result)
',name))
(defparameter *primitive-type-slot-alist*
'((:check . primitive-type-check)))
+;;; Primitive-Type-VOP Vop (Kind*) Type*
+;;;
+;;; Annotate all the specified primitive Types with the named VOP
+;;; under each of the specified kinds:
+;;;
+;;; :CHECK
+;;; A one-argument one-result VOP that moves the argument to the
+;;; result, checking that the value is of this type in the process.
(defmacro primitive-type-vop (vop kinds &rest types)
- #!+sb-doc
- "Primitive-Type-VOP Vop (Kind*) Type*
- Annotate all the specified primitive Types with the named VOP under each of
- the specified kinds:
-
- :Check
- A one argument one result VOP that moves the argument to the result,
- checking that the value is of this type in the process."
(let ((n-vop (gensym))
(n-type (gensym)))
`(let ((,n-vop (template-or-lose ',vop)))
,@(mapcar
- #'(lambda (type)
- `(let ((,n-type (primitive-type-or-lose ',type)))
- ,@(mapcar
- #'(lambda (kind)
- (let ((slot (or (cdr (assoc kind
- *primitive-type-slot-alist*))
- (error "unknown kind: ~S" kind))))
- `(setf (,slot ,n-type) ,n-vop)))
- kinds)))
+ (lambda (type)
+ `(let ((,n-type (primitive-type-or-lose ',type)))
+ ,@(mapcar
+ (lambda (kind)
+ (let ((slot (or (cdr (assoc kind
+ *primitive-type-slot-alist*))
+ (error "unknown kind: ~S" kind))))
+ `(setf (,slot ,n-type) ,n-vop)))
+ kinds)))
types)
nil)))
-;;; Return true if SC is either one of Ptype's SC's, or one of those SC's
-;;; alternate or constant SCs.
+;;; Return true if SC is either one of PTYPE's SC's, or one of those
+;;; SC's alternate or constant SCs.
(defun meta-sc-allowed-by-primitive-type (sc ptype)
(declare (type sc sc) (type primitive-type ptype))
(let ((scn (sc-number sc)))
\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-ARG 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:
- (kind (required-argument)
+ ;; the way this operand is used:
+ (kind (missing-arg)
: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))
(error "~S is not an operand to ~S." name (vop-parse-name parse))))
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.
+;;; 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.
(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)
(declare (type operand-parse temp))
(let ((sc (operand-parse-sc temp))
(offset (operand-parse-offset temp)))
- (assert sc)
+ (aver sc)
(setf (aref results index)
(if offset
(+ (ash offset (1+ sc-bits))
(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)
(operand-parse-name op)))
(let ((target (find-operand (operand-parse-target op) parse
'(:temporary :result))))
+ ;; KLUDGE: These formulas must be consistent with those in
+ ;; %EMIT-GENERIC-VOP, and this is currently maintained by
+ ;; hand. -- WHN 2002-01-30, paraphrasing APD
(targets (+ (* index max-vop-tn-refs)
(ecase (operand-parse-kind target)
(:result
(+ (* (position-or-lose target
(vop-parse-temps parse))
2)
- num-args num-results)))))))
+ 1
+ num-args
+ num-results)))))))
(let ((born (operand-parse-born op))
(dies (operand-parse-dies op)))
(ecase (operand-parse-kind op)
(refs (cons (cons born t) index))))
(incf index)))
(let* ((sorted (sort (refs)
- #'(lambda (x y)
- (let ((x-time (car x))
- (y-time (car y)))
- (if (time-spec-order x-time y-time)
- (if (time-spec-order y-time x-time)
- (and (not (cdr x)) (cdr y))
- nil)
- t)))
+ (lambda (x y)
+ (let ((x-time (car x))
+ (y-time (car y)))
+ (if (time-spec-order x-time y-time)
+ (if (time-spec-order y-time x-time)
+ (and (not (cdr x)) (cdr y))
+ nil)
+ t)))
:key #'car))
(oe-type '(mod #.max-vop-tn-refs)) ; :REF-ORDERING element type
(te-type '(mod #.(* max-vop-tn-refs 2))) ; :TARGETS element type
(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.
-(defun find-move-functions (op load-p)
+;;; 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-funs (op load-p)
(collect ((funs))
(dolist (sc-name (operand-parse-scs op))
(let* ((sc (meta-sc-or-lose sc-name))
(unless (member (sc-name alt) (operand-parse-scs op) :test #'eq)
(let* ((altn (sc-number alt))
(name (if load-p
- (svref (sc-move-functions sc) altn)
- (svref (sc-move-functions alt) scn)))
+ (svref (sc-move-funs sc) altn)
+ (svref (sc-move-funs alt) scn)))
(found (or (assoc alt (funs) :test #'member)
(rassoc name (funs)))))
(unless name
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.
-(defun call-move-function (parse op load-p)
- (let ((funs (find-move-functions op load-p))
+;;; 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-fun (parse op load-p)
+ (let ((funs (find-move-funs op load-p))
(load-tn (operand-parse-load-tn op)))
(if funs
(let* ((tn `(tn-ref-tn ,(operand-parse-temp op)))
(setf (vop-parse-vop-var parse) (gensym))))
(form (if (rest funs)
`(sc-case ,tn
- ,@(mapcar #'(lambda (x)
- `(,(mapcar #'sc-name (car x))
- ,(if load-p
- `(,(cdr x) ,n-vop ,tn
- ,load-tn)
- `(,(cdr x) ,n-vop ,load-tn
- ,tn))))
+ ,@(mapcar (lambda (x)
+ `(,(mapcar #'sc-name (car x))
+ ,(if load-p
+ `(,(cdr x) ,n-vop ,tn
+ ,load-tn)
+ `(,(cdr x) ,n-vop ,load-tn
+ ,tn))))
funs))
(if load-p
`(,(cdr (first funs)) ,n-vop ,tn ,load-tn)
(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))
,load-tn
(tn-ref-tn ,temp))))))
-;;; Make a lambda that parses the VOP TN-Refs, does automatic operand
+;;; Make a lambda that parses the VOP TN-REFS, does automatic operand
;;; loading, and runs the appropriate code generator.
(defun make-generator-function (parse)
(declare (type vop-parse parse))
(tn-ref-load-tn ,temp)))
(binds `(,name ,(decide-to-load parse op)))
(if (eq (operand-parse-kind op) :argument)
- (loads (call-move-function parse op t))
- (saves (call-move-function parse op nil))))
+ (loads (call-move-fun parse op t))
+ (saves (call-move-fun parse op nil))))
(t
(binds `(,name (tn-ref-tn ,temp)))))))
(:temporary
(tn-ref-tn ,(operand-parse-temp op)))))
((:more-argument :more-result))))
- `#'(lambda (,n-vop)
- (let* (,@(access-operands (vop-parse-args parse)
- (vop-parse-more-args parse)
- `(vop-args ,n-vop))
+ `(lambda (,n-vop)
+ (let* (,@(access-operands (vop-parse-args parse)
+ (vop-parse-more-args parse)
+ `(vop-args ,n-vop))
,@(access-operands (vop-parse-results parse)
(vop-parse-more-results parse)
`(vop-results ,n-vop))
`(vop-temps ,n-vop))
,@(when (vop-parse-info-args parse)
`((,n-info (vop-codegen-info ,n-vop))
- ,@(mapcar #'(lambda (x) `(,x (pop ,n-info)))
+ ,@(mapcar (lambda (x) `(,x (pop ,n-info)))
(vop-parse-info-args parse))))
,@(when (vop-parse-variant-vars parse)
`((,n-variant (vop-info-variant (vop-info ,n-vop)))
- ,@(mapcar #'(lambda (x) `(,x (pop ,n-variant)))
+ ,@(mapcar (lambda (x) `(,x (pop ,n-variant)))
(vop-parse-variant-vars parse))))
,@(when (vop-parse-node-var parse)
`((,(vop-parse-node-var parse) (vop-node ,n-vop))))
,@(binds))
- (declare (ignore ,@(vop-parse-ignores parse)))
- ,@(loads)
- (sb!assem:assemble (*code-segment* ,n-vop)
- ,@(vop-parse-body parse))
- ,@(saves))))))
+ (declare (ignore ,@(vop-parse-ignores parse)))
+ ,@(loads)
+ (sb!assem:assemble (*code-segment* ,n-vop)
+ ,@(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.
-(defun parse-operands (parse specs kind)
+;;; 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-vop-operands (parse specs kind)
(declare (list specs)
(type (member :argument :result) kind))
(let ((num -1)
(let ((value (second key)))
(case (first key)
(:scs
- (check-type value list)
+ (aver (typep value 'list))
(setf (operand-parse-scs res) (remove-duplicates value)))
(:load-tn
- (check-type value symbol)
+ (aver (typep value 'symbol))
(setf (operand-parse-load-tn res) value))
(:load-if
(setf (operand-parse-load res) value))
(:more
- (check-type value boolean)
+ (aver (typep value 'boolean))
(setf (operand-parse-kind res)
(if (eq kind :argument) :more-argument :more-result))
(setf (operand-parse-load res) nil)
(setq more res))
(:target
- (check-type value symbol)
+ (aver (typep value 'symbol))
(setf (operand-parse-target res) value))
(:from
(unless (eq kind :result)
(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))
(vop-spec-arg opt 'symbol 1 nil)))
(:offset
(let ((offset (eval (second opt))))
- (check-type offset unsigned-byte)
+ (aver (typep offset 'unsigned-byte))
(setf (operand-parse-offset res) offset)))
(:from
(setf (operand-parse-born res) (parse-time-spec (second opt))))
(:to
(setf (operand-parse-dies res) (parse-time-spec (second opt))))
- ;; Backward compatibility...
+ ;; backward compatibility...
(:scs
(let ((scs (vop-spec-arg opt 'list 1 nil)))
(unless (= (length scs) 1)
: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)
(case (first spec)
(:args
(multiple-value-bind (fixed more)
- (parse-operands parse (rest spec) :argument)
+ (!parse-vop-operands parse (rest spec) :argument)
(setf (vop-parse-args parse) fixed)
(setf (vop-parse-more-args parse) more)))
(:results
(multiple-value-bind (fixed more)
- (parse-operands parse (rest spec) :result)
+ (!parse-vop-operands parse (rest spec) :result)
(setf (vop-parse-results parse) fixed)
(setf (vop-parse-more-results parse) more))
(setf (vop-parse-conditional-p parse) nil))
(setf (vop-parse-note parse) (vop-spec-arg spec '(or string null))))
(:arg-types
(setf (vop-parse-arg-types parse)
- (parse-operand-types (rest spec) t)))
+ (!parse-vop-operand-types (rest spec) t)))
(:result-types
(setf (vop-parse-result-types parse)
- (parse-operand-types (rest spec) nil)))
+ (!parse-vop-operand-types (rest spec) nil)))
(:translate
(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))
(make-array sc-number-limit :initial-element 0))
(defparameter *no-loads*
- (make-array sc-number-limit :initial-element 't))
+ (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)
\f
;;;; operand checking and stuff
-;;; Given a list of arg/result restrictions, check for valid syntax and
-;;; convert to canonical form.
-(defun parse-operand-types (specs args-p)
+;;; Given a list of arg/result restrictions, check for valid syntax
+;;; and convert to canonical form.
+(defun !parse-vop-operand-types (specs args-p)
(declare (list specs))
(labels ((parse-operand-type (spec)
(cond ((eq spec '*) spec)
(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)))
+ (let ((ptypes (if (eq type '*) (list t) (rest type)))
(scs (operand-parse-scs op)))
(when scs
(multiple-value-bind (costs load-scs) (compute-loading-costs op load-p)
(type (or operand-parse null) more-op))
(unless (eq types :unspecified)
(let ((num (+ (length ops) (if more-op 1 0))))
- (unless (= (count-if-not #'(lambda (x)
- (and (consp x)
- (eq (car x) :constant)))
+ (unless (= (count-if-not (lambda (x)
+ (and (consp x)
+ (eq (car x) :constant)))
types)
num)
- (error "expected ~D ~:[result~;argument~] type~P: ~S"
+ (error "expected ~W ~:[result~;argument~] type~P: ~S"
num load-p types num)))
(when more-op
(when (vop-parse-translate parse)
(let ((types (specify-operand-types types ops more-op)))
- (mapc #'(lambda (x y)
- (check-operand-type-scs parse x y load-p))
+ (mapc (lambda (x y)
+ (check-operand-type-scs parse x y load-p))
(if more-op (butlast ops) ops)
- (remove-if #'(lambda (x)
- (and (consp x)
- (eq (car x) ':constant)))
+ (remove-if (lambda (x)
+ (and (consp x)
+ (eq (car x) ':constant)))
(if more-op (butlast types) types)))))
(values))
;;; Compute stuff that can only be computed after we are done parsing
-;;; everying. We set the VOP-Parse-Operands, and do various error checks.
-(defun grovel-operands (parse)
+;;; everying. We set the VOP-PARSE-OPERANDS, and do various error checks.
+(defun !grovel-vop-operands (parse)
(declare (type vop-parse parse))
(setf (vop-parse-operands parse)
\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.
-(defun set-up-function-translation (parse n-template)
+;;; 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-fun-translation (parse n-template)
(declare (type vop-parse parse))
- (mapcar #'(lambda (name)
- `(let ((info (function-info-or-lose ',name)))
- (setf (function-info-templates info)
- (adjoin-template ,n-template
- (function-info-templates info)))
- ,@(when (vop-parse-conditional-p parse)
- '((setf (function-info-attributes info)
- (attributes-union
- (ir1-attributes predicate)
- (function-info-attributes info)))))))
+ (mapcar (lambda (name)
+ `(let ((info (fun-info-or-lose ',name)))
+ (setf (fun-info-templates info)
+ (adjoin-template ,n-template (fun-info-templates info)))
+ ,@(when (vop-parse-conditional-p parse)
+ '((setf (fun-info-attributes info)
+ (attributes-union
+ (ir1-attributes predicate)
+ (fun-info-attributes info)))))))
(vop-parse-translate parse)))
;;; Return a form that can be evaluated to get the TEMPLATE operand type
(t
(ecase (first type)
(:or
- ``(:or ,,@(mapcar #'(lambda (type)
- `(primitive-type-or-lose ',type))
- (rest type))))
+ ``(:or ,,@(mapcar (lambda (type)
+ `(primitive-type-or-lose ',type))
+ (rest type))))
(:constant
``(:constant ,#'(lambda (x)
(typep x ',(second type)))
(make-list (+ (length ops) (if more-ops 1 0)) :initial-element '*)
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.
+;;; Return a list of forms to use as &KEY 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.
(defun make-vop-info-types (parse)
(let* ((more-args (vop-parse-more-args parse))
(all-args (specify-operand-types (vop-parse-arg-types parse)
(more-result (when more-results (car (last all-results))))
(conditional (vop-parse-conditional-p parse)))
- `(
- :type (specifier-type '(function () nil))
+ `(:type (specifier-type '(function () nil))
:arg-types (list ,@(mapcar #'make-operand-type args))
:more-args-type ,(when more-args (make-operand-type more-arg))
:result-types ,(if conditional
\f
;;;; setting up VOP-INFO
-(defconstant slot-inherit-alist
- '((: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.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *slot-inherit-alist*
+ '((:generator-function . vop-info-generator-function))))
+
+;;; This is 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.
(defmacro inherit-vop-info (slot parse test form)
`(if (and ,parse ,test)
- (list ,slot `(,',(or (cdr (assoc slot slot-inherit-alist))
+ (list ,slot `(,',(or (cdr (assoc slot *slot-inherit-alist*))
(error "unknown slot ~S" slot))
(template-or-lose ',(vop-parse-name ,parse))))
(list ,slot ,form)))
-;;; Return a form that creates a VOP-Info structure which describes VOP.
+;;; Return a form that creates a VOP-INFO structure which describes VOP.
(defun set-up-vop-info (iparse parse)
(declare (type vop-parse parse) (type (or vop-parse null) iparse))
(let ((same-operands
(let ((nvars (length (vop-parse-variant-vars parse))))
(unless (= (length variant) nvars)
- (error "expected ~D variant values: ~S" nvars variant)))
+ (error "expected ~W variant values: ~S" nvars variant)))
`(make-vop-info
:name ',(vop-parse-name parse)
,@(make-vop-info-types parse)
:guard ,(when (vop-parse-guard parse)
- `#'(lambda () ,(vop-parse-guard parse)))
+ `(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.
+;;; Define the symbol NAME to be a Virtual OPeration in the compiler.
+;;; If specified, INHERITS is the name of a VOP that we default
+;;; unspecified information from. Each SPEC is a list beginning with a
+;;; keyword indicating the interpretation of the other forms in the
+;;; SPEC:
+;;;
+;;; :ARGS {(Name {Key Value}*)}*
+;;; :RESULTS {(Name {Key Value}*)}*
+;;; The Args and Results are specifications of the operand TNs passed
+;;; to the VOP. If there is an inherited VOP, any unspecified options
+;;; are defaulted from the inherited argument (or result) of the same
+;;; name. The following operand options are defined:
+;;;
+;;; :SCs (SC*)
+;;; :SCs specifies good SCs for this operand. Other SCs will
+;;; be penalized according to move costs. A load TN will be
+;;; allocated if necessary, guaranteeing that the operand is
+;;; always one of the specified SCs.
+;;;
+;;; :LOAD-TN Load-Name
+;;; Load-Name is bound to the load TN allocated for this
+;;; operand, or to NIL if no load TN was allocated.
+;;;
+;;; :LOAD-IF EXPRESSION
+;;; Controls whether automatic operand loading is done.
+;;; EXPRESSION is evaluated with the fixed operand TNs bound.
+;;; If EXPRESSION is true,then loading is done and the variable
+;;; is bound to the load TN in the generator body. Otherwise,
+;;; loading is not done, and the variable is bound to the actual
+;;; operand.
+;;;
+;;; :MORE T-or-NIL
+;;; If specified, NAME is bound to the TN-REF for the first
+;;; argument or result following the fixed arguments or results.
+;;; A :MORE operand must appear last, and cannot be targeted or
+;;; restricted.
+;;;
+;;; :TARGET Operand
+;;; This operand is targeted to the named operand, indicating a
+;;; desire to pack in the same location. Not legal for results.
+;;;
+;;; :FROM Time-Spec
+;;; :TO Time-Spec
+;;; Specify the beginning or end of the operand's lifetime.
+;;; :FROM can only be used with results, and :TO only with
+;;; arguments. The default for the N'th argument/result is
+;;; (:ARGUMENT N)/(:RESULT N). These options are necessary
+;;; primarily when operands are read or written out of order.
+;;;
+;;; :CONDITIONAL
+;;; This is used in place of :RESULTS with conditional branch VOPs.
+;;; There are no result values: the result is a transfer of control.
+;;; The target label is passed as the first :INFO arg. The second
+;;; :INFO arg is true if the sense of the test should be negated.
+;;; A side effect is to set the PREDICATE attribute for functions
+;;; in the :TRANSLATE option.
+;;;
+;;; :TEMPORARY ({Key Value}*) Name*
+;;; Allocate a temporary TN for each Name, binding that variable to
+;;; the TN within the body of the generators. In addition to :TARGET
+;;; (which is is the same as for operands), the following options are
+;;; defined:
+;;;
+;;; :SC SC-Name
+;;; :OFFSET SB-Offset
+;;; Force the temporary to be allocated in the specified SC
+;;; with the specified offset. Offset is evaluated at
+;;; macroexpand time. If Offset is emitted, the register
+;;; allocator chooses a free location in SC. If both SC and
+;;; Offset are omitted, then the temporary is packed according
+;;; to its primitive type.
+;;;
+;;; :FROM Time-Spec
+;;; :TO Time-Spec
+;;; Similar to the argument/result option, this specifies the
+;;; start and end of the temporaries' lives. The defaults are
+;;; :LOAD and :SAVE, i.e. the duration of the VOP. The other
+;;; intervening phases are :ARGUMENT,:EVAL and :RESULT.
+;;; Non-zero sub-phases can be specified by a list, e.g. by
+;;; default the second argument's life ends at (:ARGUMENT 1).
+;;;
+;;; :GENERATOR Cost Form*
+;;; Specifies the translation into assembly code. Cost is the
+;;; estimated cost of the code emitted by this generator. The body
+;;; is arbitrary Lisp code that emits the assembly language
+;;; translation of the VOP. An ASSEMBLE form is wrapped around
+;;; the body, so code may be emitted by using the local INST macro.
+;;; During the evaluation of the body, the names of the operands
+;;; and temporaries are bound to the actual TNs.
+;;;
+;;; :EFFECTS Effect*
+;;; :AFFECTED Effect*
+;;; Specifies the side effects that this VOP has and the side
+;;; effects that effect its execution. If unspecified, these
+;;; default to the worst case.
+;;;
+;;; :INFO Name*
+;;; Define some magic arguments that are passed directly to the code
+;;; generator. The corresponding trailing arguments to VOP or
+;;; %PRIMITIVE are stored in the VOP structure. Within the body
+;;; of the generators, the named variables are bound to these
+;;; values. Except in the case of :CONDITIONAL VOPs, :INFO arguments
+;;; cannot be specified for VOPS that are the direct translation
+;;; for a function (specified by :TRANSLATE).
+;;;
+;;; :IGNORE Name*
+;;; Causes the named variables to be declared IGNORE in the
+;;; generator body.
+;;;
+;;; :VARIANT Thing*
+;;; :VARIANT-VARS Name*
+;;; These options provide a way to parameterize families of VOPs
+;;; that differ only trivially. :VARIANT makes the specified
+;;; evaluated Things be the "variant" associated with this VOP.
+;;; :VARIANT-VARS causes the named variables to be bound to the
+;;; corresponding Things within the body of the generator.
+;;;
+;;; :VARIANT-COST Cost
+;;; Specifies the cost of this VOP, overriding the cost of any
+;;; inherited generator.
+;;;
+;;; :NOTE {String | NIL}
+;;; A short noun-like phrase describing what this VOP "does", i.e.
+;;; the implementation strategy. If supplied, efficiency notes will
+;;; be generated when type uncertainty prevents :TRANSLATE from
+;;; working. NIL inhibits any efficiency note.
+;;;
+;;; :ARG-TYPES {* | PType | (:OR PType*) | (:CONSTANT Type)}*
+;;; :RESULT-TYPES {* | PType | (:OR PType*)}*
+;;; Specify the template type restrictions used for automatic
+;;; translation. If there is a :MORE operand, the last type is the
+;;; more type. :CONSTANT specifies that the argument must be a
+;;; compile-time constant of the specified Lisp type. The constant
+;;; values of :CONSTANT arguments are passed as additional :INFO
+;;; arguments rather than as :ARGS.
+;;;
+;;; :TRANSLATE Name*
+;;; This option causes the VOP template to be entered as an IR2
+;;; translation for the named functions.
+;;;
+;;; :POLICY {:SMALL | :FAST | :SAFE | :FAST-SAFE}
+;;; Specifies the policy under which this VOP is the best translation.
+;;;
+;;; :GUARD Form
+;;; Specifies a Form that is evaluated in the global environment.
+;;; If form returns NIL, then emission of this VOP is prohibited
+;;; even when all other restrictions are met.
+;;;
+;;; :VOP-VAR Name
+;;; :NODE-VAR Name
+;;; In the generator, bind the specified variable to the VOP or
+;;; the Node that generated this VOP.
+;;;
+;;; :SAVE-P {NIL | T | :COMPUTE-ONLY | :FORCE-TO-STACK}
+;;; Indicates how a VOP wants live registers saved.
+;;;
+;;; :MOVE-ARGS {NIL | :FULL-CALL | :LOCAL-CALL | :KNOWN-RETURN}
+;;; Indicates if and how the more args should be moved into a
+;;; different frame.
(def!macro define-vop ((name &optional inherits) &rest specs)
- #!+sb-doc
- "Define-VOP (Name [Inherits]) Spec*
- Define the symbol Name to be a Virtual OPeration in the compiler. If
- specified, Inherits is the name of a VOP that we default unspecified
- information from. Each Spec is a list beginning with a keyword indicating
- the interpretation of the other forms in the Spec:
-
- :Args {(Name {Key Value}*)}*
- :Results {(Name {Key Value}*)}*
- The Args and Results are specifications of the operand TNs passed to the
- VOP. If there is an inherited VOP, any unspecified options are defaulted
- from the inherited argument (or result) of the same name. The following
- operand options are defined:
-
- :SCs (SC*)
- :SCs specifies good SCs for this operand. Other SCs will be
- penalized according to move costs. A load TN will be allocated if
- necessary, guaranteeing that the operand is always one of the
- specified SCs.
-
- :Load-TN Load-Name
- Load-Name is bound to the load TN allocated for this operand, or to
- NIL if no load TN was allocated.
-
- :Load-If Expression
- Controls whether automatic operand loading is done. Expression is
- evaluated with the fixed operand TNs bound. If Expression is true,
- then loading is done and the variable is bound to the load TN in
- the generator body. Otherwise, loading is not done, and the variable
- is bound to the actual operand.
-
- :More T-or-NIL
- If specified, Name is bound to the TN-Ref for the first argument or
- result following the fixed arguments or results. A more operand must
- appear last, and cannot be targeted or restricted.
-
- :Target Operand
- This operand is targeted to the named operand, indicating a desire to
- pack in the same location. Not legal for results.
-
- :From Time-Spec
- :To Time-Spec
- Specify the beginning or end of the operand's lifetime. :From can
- only be used with results, and :To only with arguments. The default
- for the N'th argument/result is (:ARGUMENT N)/(:RESULT N). These
- options are necessary primarily when operands are read or written out
- of order.
-
- :Conditional
- This is used in place of :RESULTS with conditional branch VOPs. There
- are no result values: the result is a transfer of control. The target
- label is passed as the first :INFO arg. The second :INFO arg is true if
- the sense of the test should be negated. A side-effect is to set the
- PREDICATE attribute for functions in the :TRANSLATE option.
-
- :Temporary ({Key Value}*) Name*
- Allocate a temporary TN for each Name, binding that variable to the TN
- within the body of the generators. In addition to :Target (which is
- is the same as for operands), the following options are
- defined:
-
- :SC SC-Name
- :Offset SB-Offset
- Force the temporary to be allocated in the specified SC with the
- specified offset. Offset is evaluated at macroexpand time. If
- Offset is emitted, the register allocator chooses a free location in
- SC. If both SC and Offset are omitted, then the temporary is packed
- according to its primitive type.
-
- :From Time-Spec
- :To Time-Spec
- Similar to the argument/result option, this specifies the start and
- end of the temporaries' lives. The defaults are :Load and :Save,
- i.e. the duration of the VOP. The other intervening phases are
- :Argument,:Eval and :Result. Non-zero sub-phases can be specified
- by a list, e.g. by default the second argument's life ends at
- (:Argument 1).
-
- :Generator Cost Form*
- Specifies the translation into assembly code. Cost is the estimated cost
- of the code emitted by this generator. The body is arbitrary Lisp code
- that emits the assembly language translation of the VOP. An Assemble
- form is wrapped around the body, so code may be emitted by using the
- local Inst macro. During the evaluation of the body, the names of the
- operands and temporaries are bound to the actual TNs.
-
- :Effects Effect*
- :Affected Effect*
- Specifies the side effects that this VOP has and the side effects that
- effect its execution. If unspecified, these default to the worst case.
-
- :Info Name*
- Define some magic arguments that are passed directly to the code
- generator. The corresponding trailing arguments to VOP or %Primitive are
- stored in the VOP structure. Within the body of the generators, the
- named variables are bound to these values. Except in the case of
- :Conditional VOPs, :Info arguments cannot be specified for VOPS that are
- the direct translation for a function (specified by :Translate).
-
- :Ignore Name*
- Causes the named variables to be declared IGNORE in the generator body.
-
- :Variant Thing*
- :Variant-Vars Name*
- These options provide a way to parameterize families of VOPs that differ
- only trivially. :Variant makes the specified evaluated Things be the
- \"variant\" associated with this VOP. :Variant-Vars causes the named
- variables to be bound to the corresponding Things within the body of the
- generator.
-
- :Variant-Cost Cost
- Specifies the cost of this VOP, overriding the cost of any inherited
- generator.
-
- :Note {String | NIL}
- A short noun-like phrase describing what this VOP \"does\", i.e. the
- implementation strategy. If supplied, efficency notes will be generated
- when type uncertainty prevents :TRANSLATE from working. NIL inhibits any
- efficency note.
-
- :Arg-Types {* | PType | (:OR PType*) | (:CONSTANT Type)}*
- :Result-Types {* | PType | (:OR PType*)}*
- Specify the template type restrictions used for automatic translation.
- If there is a :More operand, the last type is the more type. :CONSTANT
- specifies that the argument must be a compile-time constant of the
- specified Lisp type. The constant values of :CONSTANT arguments are
- passed as additional :INFO arguments rather than as :ARGS.
-
- :Translate Name*
- This option causes the VOP template to be entered as an IR2 translation
- for the named functions.
-
- :Policy {:Small | :Fast | :Safe | :Fast-Safe}
- Specifies the policy under which this VOP is the best translation.
-
- :Guard Form
- Specifies a Form that is evaluated in the global environment. If
- form returns NIL, then emission of this VOP is prohibited even when
- all other restrictions are met.
-
- :VOP-Var Name
- :Node-Var Name
- In the generator, bind the specified variable to the VOP or the Node that
- generated this VOP.
-
- :Save-P {NIL | T | :Compute-Only | :Force-To-Stack}
- Indicates how a VOP wants live registers saved.
-
- :Move-Args {NIL | :Full-Call | :Local-Call | :Known-Return}
- Indicates if and how the more args should be moved into a different
- frame."
- (check-type name symbol)
-
- (let* ((iparse (when inherits
- (vop-parse-or-lose inherits)))
+ (declare (type symbol name))
+ ;; 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.
+ (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 (vop-parse-inherits parse) inherits)
(parse-define-vop parse specs)
- (grovel-operands parse)
+ (!grovel-vop-operands parse)
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(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)))
- ,@(set-up-function-translation parse n-res))
+ ,@(!set-up-fun-translation parse n-res))
',name)))
\f
;;;; 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))
(values (forms) (binds) n-head))))
+;;; Emit-Template Node Block Template Args Results [Info]
+;;;
+;;; Call the emit function for TEMPLATE, linking the result in at the
+;;; end of BLOCK.
(defmacro emit-template (node block template args results &optional info)
- #!+sb-doc
- "Emit-Template Node Block Template Args Results [Info]
- Call the emit function for Template, linking the result in at the end of
- Block."
(let ((n-first (gensym))
(n-last (gensym)))
(once-only ((n-node node)
,@(when info `(,info)))
(insert-vop-sequence ,n-first ,n-last ,n-block nil)))))
+;;; VOP Name Node Block Arg* Info* Result*
+;;;
+;;; Emit the VOP (or other template) NAME at the end of the IR2-BLOCK
+;;; BLOCK, using NODE for the source context. The interpretation of
+;;; the remaining arguments depends on the number of operands of
+;;; various kinds that are declared in the template definition. VOP
+;;; cannot be used for templates that have more-args or more-results,
+;;; since the number of arguments and results is indeterminate for
+;;; these templates. Use VOP* instead.
+;;;
+;;; ARGS and RESULTS are the TNs that are to be referenced by the
+;;; template as arguments and results. If the template has
+;;; codegen-info arguments, then the appropriate number of INFO forms
+;;; following the arguments are used for codegen info.
(defmacro vop (name node block &rest operands)
- #!+sb-doc
- "VOP Name Node Block Arg* Info* Result*
- Emit the VOP (or other template) Name at the end of the IR2-Block Block,
- using Node for the source context. The interpretation of the remaining
- arguments depends on the number of operands of various kinds that are
- declared in the template definition. VOP cannot be used for templates that
- have more-args or more-results, since the number of arguments and results is
- indeterminate for these templates. Use VOP* instead.
-
- Args and Results are the TNs that are to be referenced by the template
- as arguments and results. If the template has codegen-info arguments, then
- the appropriate number of Info forms following the Arguments are used for
- codegen info."
(let* ((parse (vop-parse-or-lose name))
(arg-count (length (vop-parse-args parse)))
(result-count (length (vop-parse-results parse)))
(when (or (vop-parse-more-args parse) (vop-parse-more-results parse))
(error "cannot use VOP with variable operand count templates"))
(unless (= noperands (length operands))
- (error "called with ~D operands, but was expecting ~D"
+ (error "called with ~W operands, but was expecting ~W"
(length operands) noperands))
(multiple-value-bind (acode abinds n-args)
(make-operand-list (subseq operands 0 arg-count) nil nil)
(multiple-value-bind (rcode rbinds n-results)
(make-operand-list (subseq operands (+ arg-count info-count)) nil t)
-
+
(collect ((ibinds)
(ivars))
(dolist (info (subseq operands arg-count (+ arg-count info-count)))
`((list ,@(ivars)))))
(values)))))))
+;;; VOP* Name Node Block (Arg* More-Args) (Result* More-Results) Info*
+;;;
+;;; This is like VOP, but allows for emission of templates with
+;;; arbitrary numbers of arguments, and for emission of templates
+;;; using already-created TN-REF lists.
+;;;
+;;; The ARGS and RESULTS are TNs to be referenced as the first
+;;; arguments and results to the template. More-Args and More-Results
+;;; are heads of TN-REF lists that are added onto the end of the
+;;; TN-REFS for the explicitly supplied operand TNs. The TN-REFS for
+;;; the more operands must have the TN and WRITE-P slots correctly
+;;; initialized.
+;;;
+;;; As with VOP, the INFO forms are evaluated and passed as codegen
+;;; info arguments.
(defmacro vop* (name node block args results &rest info)
- #!+sb-doc
- "VOP* Name Node Block (Arg* More-Args) (Result* More-Results) Info*
- Like VOP, but allows for emission of templates with arbitrary numbers of
- arguments, and for emission of templates using already-created TN-Ref lists.
-
- The Arguments and Results are TNs to be referenced as the first arguments
- and results to the template. More-Args and More-Results are heads of TN-Ref
- lists that are added onto the end of the TN-Refs for the explicitly supplied
- operand TNs. The TN-Refs for the more operands must have the TN and Write-P
- slots correctly initialized.
-
- As with VOP, the Info forms are evaluated and passed as codegen info
- arguments."
- (check-type args cons)
- (check-type results cons)
+ (declare (type cons args results))
(let* ((parse (vop-parse-or-lose name))
(arg-count (length (vop-parse-args parse)))
(result-count (length (vop-parse-results parse)))
(<= (length fixed-results) result-count))
(error "too many fixed results"))
(unless (= (length info) info-count)
- (error "expected ~D info args" info-count))
+ (error "expected ~W info args" info-count))
(multiple-value-bind (acode abinds n-args)
(make-operand-list fixed-args (car (last args)) nil)
(multiple-value-bind (rcode rbinds n-results)
(make-operand-list fixed-results (car (last results)) t)
-
+
`(let* ((,n-node ,node)
(,n-block ,block)
(,n-template (template-or-lose ',name))
\f
;;;; miscellaneous macros
+;;; SC-Case TN {({(SC-Name*) | SC-Name | T} Form*)}*
+;;;
+;;; Case off of TN's SC. The first clause containing TN's SC is
+;;; evaluated, returning the values of the last form. A clause
+;;; beginning with T specifies a default. If it appears, it must be
+;;; last. If no default is specified, and no clause matches, then an
+;;; error is signalled.
(def!macro sc-case (tn &rest forms)
- #!+sb-doc
- "SC-Case TN {({(SC-Name*) | SC-Name | T} Form*)}*
- Case off of TN's SC. The first clause containing TN's SC is evaluated,
- returning the values of the last form. A clause beginning with T specifies a
- default. If it appears, it must be last. If no default is specified, and no
- clause matches, then an error is signalled."
(let ((n-sc (gensym))
(n-tn (gensym)))
(collect ((clauses))
(do ((cases forms (rest cases)))
((null cases)
- (clauses `(t (error "unknown SC to SC-Case for ~S:~% ~S" ,n-tn
+ (clauses `(t (error "unknown SC to SC-CASE for ~S:~% ~S" ,n-tn
(sc-name (tn-sc ,n-tn))))))
(let ((case (first cases)))
(when (atom case)
- (error "illegal SC-Case clause: ~S" case))
+ (error "illegal SC-CASE clause: ~S" case))
(let ((head (first case)))
(when (eq head t)
(when (rest cases)
- (error "T case is not last in SC-Case."))
+ (error "T case is not last in SC-CASE."))
(clauses `(t nil ,@(rest case)))
(return))
- (clauses `((or ,@(mapcar #'(lambda (x)
- `(eql ,(meta-sc-number-or-lose x)
- ,n-sc))
+ (clauses `((or ,@(mapcar (lambda (x)
+ `(eql ,(meta-sc-number-or-lose x)
+ ,n-sc))
(if (atom head) (list head) head)))
nil ,@(rest case))))))
(,n-sc (sc-number (tn-sc ,n-tn))))
(cond ,@(clauses))))))
+;;; Return true if TNs SC is any of the named SCs, false otherwise.
(defmacro sc-is (tn &rest scs)
- #!+sb-doc
- "SC-Is TN SC*
- Returns true if TNs SC is any of the named SCs, false otherwise."
(once-only ((n-sc `(sc-number (tn-sc ,tn))))
- `(or ,@(mapcar #'(lambda (x)
- `(eql ,n-sc ,(meta-sc-number-or-lose x)))
+ `(or ,@(mapcar (lambda (x)
+ `(eql ,n-sc ,(meta-sc-number-or-lose x)))
scs))))
+;;; Iterate over the IR2 blocks in component, in emission order.
(defmacro do-ir2-blocks ((block-var component &optional result)
&body forms)
- #!+sb-doc
- "Do-IR2-Blocks (Block-Var Component [Result]) Form*
- Iterate over the IR2 blocks in component, in emission order."
`(do ((,block-var (block-info (component-head ,component))
(ir2-block-next ,block-var)))
((null ,block-var) ,result)
,@forms))
+;;; Iterate over all the TNs live at some point, with the live set
+;;; represented by a local conflicts bit-vector and the IR2-BLOCK
+;;; containing the location.
(defmacro do-live-tns ((tn-var live block &optional result) &body body)
- #!+sb-doc
- "DO-LIVE-TNS (TN-Var Live Block [Result]) Form*
- Iterate over all the TNs live at some point, with the live set represented by
- a local conflicts bit-vector and the IR2-Block containing the location."
(let ((n-conf (gensym))
(n-bod (gensym))
(i (gensym))
(,n-bod ,tn-var))
(let ((,ltns (ir2-block-local-tns ,n-block)))
- ;; Do TNs always-live in this block and live :More TNs.
+ ;; Do TNs always-live in this block and live :MORE TNs.
(do ((,n-conf (ir2-block-global-tns ,n-block)
- (global-conflicts-next ,n-conf)))
+ (global-conflicts-next-blockwise ,n-conf)))
((null ,n-conf))
(when (or (eq (global-conflicts-kind ,n-conf) :live)
(let ((,i (global-conflicts-number ,n-conf)))
(when (and ,tn-var (not (eq ,tn-var :more)))
(,n-bod ,tn-var)))))))))))
-(defmacro do-environment-ir2-blocks ((block-var env &optional result)
- &body body)
- #!+sb-doc
- "DO-ENVIRONMENT-IR2-BLOCKS (Block-Var Env [Result]) Form*
- Iterate over all the IR2 blocks in the environment Env, in emit order."
- (once-only ((n-env env))
- (once-only ((n-first `(node-block
- (lambda-bind
- (environment-function ,n-env)))))
+;;; Iterate over all the IR2 blocks in PHYSENV, in emit order.
+(defmacro do-physenv-ir2-blocks ((block-var physenv &optional result)
+ &body body)
+ (once-only ((n-physenv physenv))
+ (once-only ((n-first `(lambda-block (physenv-lambda ,n-physenv))))
(once-only ((n-tail `(block-info
(component-tail
(block-component ,n-first)))))
`(do ((,block-var (block-info ,n-first)
(ir2-block-next ,block-var)))
((or (eq ,block-var ,n-tail)
- (not (eq (ir2-block-environment ,block-var) ,n-env)))
+ (not (eq (ir2-block-physenv ,block-var) ,n-physenv)))
,result)
,@body)))))
projects / sbcl.git / blobdiff