;;;
;;; 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)
+(defmacro define-storage-base (name kind &key size (size-increment size)
+ (size-alignment 1))
(declare (type symbol name))
(declare (type (member :finite :unbounded :non-packed) 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))
- (aver (typep size 'unsigned-byte))))
+ (aver (typep size 'unsigned-byte))
+ (aver (= 1 (logcount size-alignment)))
+ (aver (not (logtest size (1- size-alignment))))
+ (aver (not (logtest size-increment (1- size-alignment))))))
(let ((res (if (eq kind :non-packed)
- (make-sb :name name :kind kind)
- (make-finite-sb :name name :kind kind :size size))))
+ (make-sb :name name :kind kind)
+ (make-finite-sb :name name :kind kind :size size
+ :size-increment size-increment
+ :size-alignment size-alignment))))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
- (/show0 "about to SETF GETHASH META-SB-NAMES in DEFINE-STORAGE-BASE")
- (setf (gethash ',name *backend-meta-sb-names*)
- ',res))
+ (/show0 "about to SETF GETHASH META-SB-NAMES in DEFINE-STORAGE-BASE")
+ (setf (gethash ',name *backend-meta-sb-names*)
+ ',res))
(/show0 "about to SETF GETHASH SB-NAMES in DEFINE-STORAGE-BASE")
,(if (eq kind :non-packed)
- `(setf (gethash ',name *backend-sb-names*)
- (copy-sb ',res))
- `(let ((res (copy-finite-sb ',res)))
- (/show0 "not :NON-PACKED, i.e. hairy case")
- (setf (finite-sb-always-live res)
- (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.
- #+(or sb-xc sb-xc-host)
- (make-array 0 :element-type 'bit)))
- (/show0 "doing second SETF")
- (setf (finite-sb-conflicts res)
- (make-array ',size :initial-element '#()))
- (/show0 "doing third SETF")
- (setf (finite-sb-live-tns res)
- (make-array ',size :initial-element nil))
- (/show0 "doing fourth and final SETF")
- (setf (gethash ',name *backend-sb-names*)
- res)))
+ `(setf (gethash ',name *backend-sb-names*)
+ (copy-sb ',res))
+ `(let ((res (copy-finite-sb ',res)))
+ (/show0 "not :NON-PACKED, i.e. hairy case")
+ (setf (finite-sb-always-live res)
+ (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.
+ #+(or sb-xc sb-xc-host)
+ (make-array 0 :element-type 'bit)))
+ (/show0 "doing second SETF")
+ (setf (finite-sb-conflicts res)
+ (make-array ',size :initial-element '#()))
+ (/show0 "doing third SETF")
+ (setf (finite-sb-live-tns res)
+ (make-array ',size :initial-element nil))
+ (/show0 "doing fourth SETF")
+ (setf (finite-sb-always-live-count res)
+ (make-array ',size :initial-element 0))
+ (/show0 "doing fifth and final SETF")
+ (setf (gethash ',name *backend-sb-names*)
+ res)))
(/show0 "about to put SB onto/into SB-LIST")
(setf *backend-sb-list*
- (cons (sb-or-lose ',name)
- (remove ',name *backend-sb-list* :key #'sb-name)))
+ (cons (sb-or-lose ',name)
+ (remove ',name *backend-sb-list* :key #'sb-name)))
(/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:
+;;; 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.
+;;; :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.
+;;; :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.
+;;; :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*)
+;;; :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}
+;;; :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.
+;;; non-save-p :ALTERNATE-SCs across calls.
;;;
-;;; :Alternate-SCs (SC*)
+;;; :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*)
+;;; :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)
+ (alignment '1) locations reserve-locations
+ save-p alternate-scs constant-scs)
(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)))
- (declare (type unsigned-byte element-size))
- (dolist (el locations)
- (declare (type unsigned-byte el))
- (unless (<= 1 (+ el element-size) size)
- (error "SC element ~D out of bounds for ~S" el sb))))
- (when locations
- (error ":LOCATIONS is meaningless in a ~S SB." (sb-kind sb))))
+ (let ((size (sb-size sb))
+ (element-size (eval element-size)))
+ (declare (type unsigned-byte element-size))
+ (dolist (el locations)
+ (declare (type unsigned-byte el))
+ (unless (<= 1 (+ el element-size) size)
+ (error "SC element ~W out of bounds for ~S" el sb))))
+ (when locations
+ (error ":LOCATIONS is meaningless in a ~S SB." (sb-kind sb))))
(unless (subsetp reserve-locations locations)
(error "RESERVE-LOCATIONS not a subset of LOCATIONS."))
(when (and (or alternate-scs constant-scs)
- (eq (sb-kind sb) :non-packed))
+ (eq (sb-kind sb) :non-packed))
(error
"It's meaningless to specify alternate or constant SCs in a ~S SB."
(sb-kind sb))))
(let ((nstack-p
- (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)))))
- t nil)))
+ (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)))))
+ t nil)))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
- (let ((res (make-sc :name ',name :number ',number
- :sb (meta-sb-or-lose ',sb-name)
- :element-size ,element-size
- :alignment ,alignment
- :locations ',locations
- :reserve-locations ',reserve-locations
- :save-p ',save-p
- :number-stack-p ,nstack-p
- :alternate-scs (mapcar #'meta-sc-or-lose
- ',alternate-scs)
- :constant-scs (mapcar #'meta-sc-or-lose
- ',constant-scs))))
- (setf (gethash ',name *backend-meta-sc-names*) res)
- (setf (svref *backend-meta-sc-numbers* ',number) res)
- (setf (svref (sc-load-costs res) ',number) 0)))
+ (let ((res (make-sc :name ',name :number ',number
+ :sb (meta-sb-or-lose ',sb-name)
+ :element-size ,element-size
+ :alignment ,alignment
+ :locations ',locations
+ :reserve-locations ',reserve-locations
+ :save-p ',save-p
+ :number-stack-p ,nstack-p
+ :alternate-scs (mapcar #'meta-sc-or-lose
+ ',alternate-scs)
+ :constant-scs (mapcar #'meta-sc-or-lose
+ ',constant-scs))))
+ (setf (gethash ',name *backend-meta-sc-names*) res)
+ (setf (svref *backend-meta-sc-numbers* ',number) res)
+ (setf (svref (sc-load-costs res) ',number) 0)))
(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
- (sc-name old) ',name)))
+ (when (and old (not (eq (sc-name old) ',name)))
+ (warn "redefining SC number ~W from ~S to ~S" ',number
+ (sc-name old) ',name)))
(setf (svref *backend-sc-numbers* ',number)
- (meta-sc-or-lose ',name))
+ (meta-sc-or-lose ',name))
(setf (gethash ',name *backend-sc-names*)
- (meta-sc-or-lose ',name))
+ (meta-sc-or-lose ',name))
(setf (sc-sb (sc-or-lose ',name)) (sb-or-lose ',sb-name))
',name)))
\f
;;; etc.), bind TO-SC and FROM-SC to all the combinations.
(defmacro do-sc-pairs ((from-sc-var to-sc-var scs) &body body)
`(do ((froms ,scs (cddr froms))
- (tos (cdr ,scs) (cddr tos)))
+ (tos (cdr ,scs) (cddr tos)))
((null froms))
(dolist (from (car froms))
(let ((,from-sc-var (meta-sc-or-lose from)))
- (dolist (to (car tos))
- (let ((,to-sc-var (meta-sc-or-lose to)))
- ,@body))))))
+ (dolist (to (car tos))
+ (let ((,to-sc-var (meta-sc-or-lose to)))
+ ,@body))))))
;;; 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-MOVE-FUN should be compiled before any uses of
;;; DEFINE-VOP.
-(defmacro define-move-function ((name cost) lambda-list scs &body body)
+(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))
`(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-load-costs to-sc) num) ',cost)))))
+ (unless (eq from-sc to-sc)
+ (let ((num (sc-number from-sc)))
+ (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))))
+ ,@body))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *sc-vop-slots*
'((:move . sc-move-vops)
- (:move-argument . sc-move-arg-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*))
- (error "unknown kind ~S" kind))))
+ (error "unknown kind ~S" kind))))
`(progn
,@(when (eq kind :move)
- `((eval-when (:compile-toplevel :load-toplevel :execute)
- (do-sc-pairs (from-sc to-sc ',scs)
- (compute-move-costs from-sc to-sc
- ,(vop-parse-cost
- (vop-parse-or-lose name)))))))
+ `((eval-when (:compile-toplevel :load-toplevel :execute)
+ (do-sc-pairs (from-sc to-sc ',scs)
+ (compute-move-costs from-sc to-sc
+ ,(vop-parse-cost
+ (vop-parse-or-lose name)))))))
(let ((vop (template-or-lose ',name)))
- (do-sc-pairs (from-sc to-sc ',scs)
- (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc)))
- (let ((vec (,accessor dest-sc)))
- (let ((scn (sc-number from-sc)))
- (setf (svref vec scn)
- (adjoin-template vop (svref vec scn))))
- (dolist (sc (append (sc-alternate-scs from-sc)
- (sc-constant-scs from-sc)))
- (let ((scn (sc-number sc)))
- (setf (svref vec scn)
- (adjoin-template vop (svref vec scn))))))))))))
+ (do-sc-pairs (from-sc to-sc ',scs)
+ (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc)))
+ (let ((vec (,accessor dest-sc)))
+ (let ((scn (sc-number from-sc)))
+ (setf (svref vec scn)
+ (adjoin-template vop (svref vec scn))))
+ (dolist (sc (append (sc-alternate-scs from-sc)
+ (sc-constant-scs from-sc)))
+ (let ((scn (sc-number sc)))
+ (setf (svref vec scn)
+ (adjoin-template vop (svref vec scn))))))))))))
\f
;;;; primitive type definition
(defun meta-primitive-type-or-lose (name)
(the primitive-type
(or (gethash name *backend-meta-primitive-type-names*)
- (error "~S is not a defined primitive type." name))))
+ (error "~S is not a defined primitive type." name))))
;;; 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))
- (get-type `(specifier-type ',type)))
+ (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))
- `(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))
- (t
- (/show0 "in T clause of COND")
- (setf (gethash ',name *backend-primitive-type-names*)
- (make-primitive-type :name ',name
- :scs ',scns
- :type ,n-type))))
- (/show0 "done with !DEF-PRIMITIVE-TYPE")
- ',name)))))
+ (setf (gethash ',name *backend-meta-primitive-type-names*)
+ (make-primitive-type :name ',name
+ :scs ',scns
+ :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-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
+ :specifier ',type))))
+ (/show0 "done with !DEF-PRIMITIVE-TYPE")
+ ',name)))))
;;; Define NAME to be an alias for RESULT in VOP operand type restrictions.
(defmacro !def-primitive-type-alias (name result)
(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)))
+ (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)))
- types)
+ (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)))
(dolist (allowed (primitive-type-scs ptype) nil)
(when (eql allowed scn)
- (return t))
+ (return t))
(let ((allowed-sc (svref *backend-meta-sc-numbers* allowed)))
- (when (or (member sc (sc-alternate-scs allowed-sc))
- (member sc (sc-constant-scs allowed-sc)))
- (return t))))))
+ (when (or (member sc (sc-alternate-scs allowed-sc))
+ (member sc (sc-constant-scs allowed-sc)))
+ (return t))))))
\f
;;;; VOP definition structures
;;;;
;;; 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))
+ (:make-load-form-fun just-dump-it-normally)
+ #-sb-xc-host (:pure t))
;; the name of this VOP
(name nil :type symbol)
;; If true, then the name of the VOP we inherit from.
(operands nil :type list)
;; 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. T if a branchful VOP,
+ ;; a list of condition descriptor otherwise. See $ARCH/pred.lisp
+ ;; for more information.
(conditional-p nil)
;; argument and result primitive types. These are pulled out of the
;; operands, since we often want to change them without respecifying
(variant () :type list)
(variant-vars () :type list)
;; variables bound to the VOP and Vop-Node when in the generator body
- (vop-var (gensym) :type symbol)
+ (vop-var '.vop. :type symbol)
(node-var nil :type (or symbol null))
;; a list of the names of the codegen-info arguments to this VOP
(info-args () :type list)
(note nil :type (or string null))
;; a list of the names of the Effects and Affected attributes for
;; this VOP
- (effects '(any) :type list)
- (affected '(any) :type list)
+ (effects '#1=(any) :type list)
+ (affected '#1# :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
+ ;; the policy that allows this translation to be done. :FAST is a
;; safe default, since it isn't a safe policy.
(translate () :type list)
(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
+ ;; 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)
;;; 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))
+ (:make-load-form-fun just-dump-it-normally)
+ #-sb-xc-host (:pure t))
;; name of the operand (which we bind to the TN)
(name nil :type symbol)
;; the way this operand is used:
- (kind (required-argument)
- :type (member :argument :result :temporary
- :more-argument :more-result))
+ (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.
(target nil :type (or symbol null))
;; 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))
+ (temp (make-operand-parse-temp) :type symbol)
;; 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.
(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)
+ (load-tn (make-operand-parse-load-tn) :type symbol)
;; 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
;;; 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))
+ (kinds '(:argument :result :temporary))
+ (error-p t))
(declare (symbol name) (type vop-parse parse) (list kinds))
(let ((found (find name (vop-parse-operands parse)
- :key #'operand-parse-name)))
+ :key #'operand-parse-name)))
(if found
- (unless (member (operand-parse-kind found) kinds)
- (error "Operand ~S isn't one of these kinds: ~S." name kinds))
- (when error-p
- (error "~S is not an operand to ~S." name (vop-parse-name parse))))
+ (unless (member (operand-parse-kind found) kinds)
+ (error "Operand ~S isn't one of these kinds: ~S." name kinds))
+ (when error-p
+ (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))))
+ (error "~S is not the name of a defined VOP." name))))
;;; 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.
+;;; 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))
(let ((prev refs))
(dolist (op operands)
- (let ((n-ref (operand-parse-temp op)))
- (res `(,n-ref ,prev))
- (setq prev `(tn-ref-across ,n-ref))))
+ (let ((n-ref (operand-parse-temp op)))
+ (res `(,n-ref ,prev))
+ (setq prev `(tn-ref-across ,n-ref))))
(when more-operand
- (res `(,(operand-parse-name more-operand) ,prev))))
+ (res `(,(operand-parse-name more-operand) ,prev))))
(res)))
-;;; This is used with ACCESS-OPERANDS to prevent warnings for TN-Ref
+;;; 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.
+;;; the last operand, or NIL if OPERANDS is NIL.
(defun ignore-unreferenced-temps (operands)
(when operands
(operand-parse-temp (car (last operands)))))
(error "extra junk at end of ~S" spec))
(let ((thing (elt spec n)))
(unless (typep thing type)
- (error "~:R argument is not a ~S: ~S" n type spec))
+ (error "~:R argument is not a ~S: ~S" n type spec))
thing)))
\f
;;;; time specs
(defun parse-time-spec (spec)
(let ((dspec (if (atom spec) (list spec 0) spec)))
(unless (and (= (length dspec) 2)
- (typep (second dspec) 'unsigned-byte))
+ (typep (second dspec) 'unsigned-byte))
(error "malformed time specifier: ~S" spec))
(cons (case (first dspec)
- (:load 0)
- (:argument 1)
- (:eval 2)
- (:result 3)
- (:save 4)
- (t
- (error "unknown phase in time specifier: ~S" spec)))
- (second dspec))))
+ (:load 0)
+ (:argument 1)
+ (:eval 2)
+ (:result 3)
+ (:save 4)
+ (t
+ (error "unknown phase in time specifier: ~S" spec)))
+ (second dspec))))
;;; Return true if the time spec X is the same or later time than Y.
(defun time-spec-order (x y)
(or (> (car x) (car y))
(and (= (car x) (car y))
- (>= (cdr x) (cdr y)))))
+ (>= (cdr x) (cdr y)))))
\f
;;;; generation of emit functions
(defun compute-temporaries-description (parse)
(let ((temps (vop-parse-temps parse))
- (element-type '(unsigned-byte 16)))
+ (element-type '(unsigned-byte 16)))
(when temps
(let ((results (make-specializable-array
- (length temps)
- :element-type element-type))
- (index 0))
- (dolist (temp temps)
- (declare (type operand-parse temp))
- (let ((sc (operand-parse-sc temp))
- (offset (operand-parse-offset temp)))
- (aver sc)
- (setf (aref results index)
- (if offset
- (+ (ash offset (1+ sc-bits))
- (ash (meta-sc-number-or-lose sc) 1)
- 1)
- (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
- `(coerce ,results '(specializable-vector ,element-type))))))
+ (length temps)
+ :element-type element-type))
+ (index 0))
+ (dolist (temp temps)
+ (declare (type operand-parse temp))
+ (let ((sc (operand-parse-sc temp))
+ (offset (operand-parse-offset temp)))
+ (aver sc)
+ (setf (aref results index)
+ (if offset
+ (+ (ash offset (1+ sc-bits))
+ (ash (meta-sc-number-or-lose sc) 1)
+ 1)
+ (ash (meta-sc-number-or-lose sc) 1))))
+ (incf index))
+ ;; KLUDGE: The load-time MAKE-ARRAY here is an artifact of our
+ ;; cross-compilation strategy, and the conservative
+ ;; assumptions we are forced to make on which specialized
+ ;; arrays exist on the host lisp that the cross-compiler is
+ ;; running on. (We used to use COERCE here, but that caused
+ ;; SUBTYPEP calls too early in cold-init for comfort). --
+ ;; CSR, 2009-10-30
+ `(make-array ,(length results) :element-type '(specializable ,element-type) :initial-contents ',results)))))
(defun compute-ref-ordering (parse)
(let* ((num-args (+ (length (vop-parse-args parse))
- (if (vop-parse-more-args parse) 1 0)))
- (num-results (+ (length (vop-parse-results parse))
- (if (vop-parse-more-results parse) 1 0)))
- (index 0))
+ (if (vop-parse-more-args parse) 1 0)))
+ (num-results (+ (length (vop-parse-results parse))
+ (if (vop-parse-more-results parse) 1 0)))
+ (index 0))
(collect ((refs) (targets))
(dolist (op (vop-parse-operands parse))
- (when (operand-parse-target op)
- (unless (member (operand-parse-kind op) '(:argument :temporary))
- (error "cannot target a ~S operand: ~S" (operand-parse-kind op)
- (operand-parse-name op)))
- (let ((target (find-operand (operand-parse-target op) parse
- '(:temporary :result))))
- (targets (+ (* index max-vop-tn-refs)
- (ecase (operand-parse-kind target)
- (:result
- (+ (position-or-lose target
- (vop-parse-results parse))
- num-args))
- (:temporary
- (+ (* (position-or-lose target
- (vop-parse-temps parse))
- 2)
- num-args num-results)))))))
- (let ((born (operand-parse-born op))
- (dies (operand-parse-dies op)))
- (ecase (operand-parse-kind op)
- (:argument
- (refs (cons (cons dies nil) index)))
- (:more-argument
- (refs (cons (cons dies nil) index)))
- (:result
- (refs (cons (cons born t) index)))
- (:more-result
- (refs (cons (cons born t) index)))
- (:temporary
- (refs (cons (cons dies nil) index))
- (incf index)
- (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)))
- :key #'car))
- (oe-type '(mod #.max-vop-tn-refs)) ; :REF-ORDERING element type
- (te-type '(mod #.(* max-vop-tn-refs 2))) ; :TARGETS element type
- (ordering (make-specializable-array
- (length sorted)
- :element-type oe-type)))
- (let ((index 0))
- (dolist (ref sorted)
- (setf (aref ordering index) (cdr ref))
- (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
- :ref-ordering (coerce ',ordering
- '(specializable-vector ,oe-type))
- ,@(when (targets)
- `(:targets (coerce ',(targets)
- '(specializable-vector ,te-type)))))))))
+ (when (operand-parse-target op)
+ (unless (member (operand-parse-kind op) '(:argument :temporary))
+ (error "cannot target a ~S operand: ~S" (operand-parse-kind op)
+ (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-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-results parse))
+ num-args))
+ (:temporary
+ (+ (* (position-or-lose target
+ (vop-parse-temps parse))
+ 2)
+ 1
+ num-args
+ num-results)))))))
+ (let ((born (operand-parse-born op))
+ (dies (operand-parse-dies op)))
+ (ecase (operand-parse-kind op)
+ (:argument
+ (refs (cons (cons dies nil) index)))
+ (:more-argument
+ (refs (cons (cons dies nil) index)))
+ (:result
+ (refs (cons (cons born t) index)))
+ (:more-result
+ (refs (cons (cons born t) index)))
+ (:temporary
+ (refs (cons (cons dies nil) index))
+ (incf index)
+ (refs (cons (cons born t) index))))
+ (incf index)))
+ (let* ((sorted (stable-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)))
+ :key #'car))
+ ;; :REF-ORDERING element type
+ ;;
+ ;; KLUDGE: was (MOD #.MAX-VOP-TN-REFS), which is still right
+ (oe-type '(unsigned-byte 8))
+ ;; :TARGETS element-type
+ ;;
+ ;; KLUDGE: was (MOD #.(* MAX-VOP-TN-REFS 2)), which does
+ ;; not correspond to the definition in
+ ;; src/compiler/vop.lisp.
+ (te-type '(unsigned-byte 16))
+ (ordering (make-specializable-array
+ (length sorted)
+ :element-type oe-type)))
+ (let ((index 0))
+ (dolist (ref sorted)
+ (setf (aref ordering index) (cdr ref))
+ (incf index)))
+ `(:num-args ,num-args
+ :num-results ,num-results
+ ;; KLUDGE: see the comment regarding MAKE-ARRAY in
+ ;; COMPUTE-TEMPORARIES-DESCRIPTION. -- CSR, 2009-10-30
+ :ref-ordering (make-array ,(length ordering)
+ :initial-contents ',ordering
+ :element-type '(specializable ,oe-type))
+ ,@(when (targets)
+ `(:targets (make-array ,(length (targets))
+ :initial-contents ',(targets)
+ :element-type '(specializable ,te-type)))))))))
(defun make-emit-function-and-friends (parse)
- `(:emit-function #'emit-generic-vop
- :temps ,(compute-temporaries-description parse)
+ `(:temps ,(compute-temporaries-description parse)
,@(compute-ref-ordering parse)))
\f
;;;; generator functions
;;; 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)
+(defun find-move-funs (op load-p)
(collect ((funs))
(dolist (sc-name (operand-parse-scs op))
(let* ((sc (meta-sc-or-lose sc-name))
- (scn (sc-number sc))
- (load-scs (append (when load-p
- (sc-constant-scs sc))
- (sc-alternate-scs sc))))
- (cond
- (load-scs
- (dolist (alt load-scs)
- (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)))
- (found (or (assoc alt (funs) :test #'member)
- (rassoc name (funs)))))
- (unless name
- (error "no move function defined to ~:[save~;load~] SC ~S ~
- with ~S ~:[to~;from~] from SC ~S"
- load-p sc-name load-p (sc-name alt)))
-
- (cond (found
- (unless (eq (cdr found) name)
- (error "can't tell whether to ~:[save~;load~]~@
- or ~S when operand is in SC ~S"
- load-p name (cdr found) (sc-name alt)))
- (pushnew alt (car found)))
- (t
- (funs (cons (list alt) name))))))))
- ((member (sb-kind (sc-sb sc)) '(:non-packed :unbounded)))
- (t
- (error "SC ~S has no alternate~:[~; or constant~] SCs, yet it is~@
- mentioned in the restriction for operand ~S"
- sc-name load-p (operand-parse-name op))))))
+ (scn (sc-number sc))
+ (load-scs (append (when load-p
+ (sc-constant-scs sc))
+ (sc-alternate-scs sc))))
+ (cond
+ (load-scs
+ (dolist (alt load-scs)
+ (unless (member (sc-name alt) (operand-parse-scs op) :test #'eq)
+ (let* ((altn (sc-number alt))
+ (name (if load-p
+ (svref (sc-move-funs sc) altn)
+ (svref (sc-move-funs alt) scn)))
+ (found (or (assoc alt (funs) :test #'member)
+ (rassoc name (funs)))))
+ (unless name
+ (error "no move function defined to ~:[save~;load~] SC ~S ~
+ ~:[to~;from~] from SC ~S"
+ load-p sc-name load-p (sc-name alt)))
+
+ (cond (found
+ (unless (eq (cdr found) name)
+ (error "can't tell whether to ~:[save~;load~]~@
+ with ~S or ~S when operand is in SC ~S"
+ load-p name (cdr found) (sc-name alt)))
+ (pushnew alt (car found)))
+ (t
+ (funs (cons (list alt) name))))))))
+ ((member (sb-kind (sc-sb sc)) '(:non-packed :unbounded)))
+ (t
+ (error "SC ~S has no alternate~:[~; or constant~] SCs, yet it is~@
+ mentioned in the restriction for operand ~S"
+ sc-name load-p (operand-parse-name op))))))
(funs)))
;;; Return a form to load/save the specified operand when it has a
;;; 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)))
+(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)))
- (n-vop (or (vop-parse-vop-var parse)
- (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))))
- funs))
- (if load-p
- `(,(cdr (first funs)) ,n-vop ,tn ,load-tn)
- `(,(cdr (first funs)) ,n-vop ,load-tn ,tn)))))
- (if (eq (operand-parse-load op) t)
- `(when ,load-tn ,form)
- `(when (eq ,load-tn ,(operand-parse-name op))
- ,form)))
- `(when ,load-tn
- (error "load TN allocated, but no move function?~@
- VM definition is inconsistent, recompile and try again.")))))
+ (let* ((tn `(tn-ref-tn ,(operand-parse-temp op)))
+ (n-vop (or (vop-parse-vop-var parse)
+ (setf (vop-parse-vop-var parse) '.vop.)))
+ (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))))
+ funs))
+ (if load-p
+ `(,(cdr (first funs)) ,n-vop ,tn ,load-tn)
+ `(,(cdr (first funs)) ,n-vop ,load-tn ,tn)))))
+ (if (eq (operand-parse-load op) t)
+ `(when ,load-tn ,form)
+ `(when (eq ,load-tn ,(operand-parse-name op))
+ ,form)))
+ `(when ,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.
(defun decide-to-load (parse op)
(let ((load (operand-parse-load op))
- (load-tn (operand-parse-load-tn op))
- (temp (operand-parse-temp op)))
+ (load-tn (operand-parse-load-tn op))
+ (temp (operand-parse-temp op)))
(if (eq load t)
- `(or ,load-tn (tn-ref-tn ,temp))
- (collect ((binds)
- (ignores))
- (dolist (x (vop-parse-operands parse))
- (when (member (operand-parse-kind x) '(:argument :result))
- (let ((name (operand-parse-name x)))
- (binds `(,name (tn-ref-tn ,(operand-parse-temp x))))
- (ignores name))))
- `(if (and ,load-tn
- (let ,(binds)
- (declare (ignorable ,@(ignores)))
- ,load))
- ,load-tn
- (tn-ref-tn ,temp))))))
-
-;;; Make a lambda that parses the VOP TN-Refs, does automatic operand
+ `(or ,load-tn (tn-ref-tn ,temp))
+ (collect ((binds)
+ (ignores))
+ (dolist (x (vop-parse-operands parse))
+ (when (member (operand-parse-kind x) '(:argument :result))
+ (let ((name (operand-parse-name x)))
+ (binds `(,name (tn-ref-tn ,(operand-parse-temp x))))
+ (ignores name))))
+ `(if (and ,load-tn
+ (let ,(binds)
+ (declare (ignorable ,@(ignores)))
+ ,load))
+ ,load-tn
+ (tn-ref-tn ,temp))))))
+
+;;; 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))
(let ((n-vop (vop-parse-vop-var parse))
- (operands (vop-parse-operands parse))
- (n-info (gensym)) (n-variant (gensym)))
+ (operands (vop-parse-operands parse))
+ (n-info (gensym)) (n-variant (gensym)))
(collect ((binds)
- (loads)
- (saves))
+ (loads)
+ (saves))
(dolist (op operands)
- (ecase (operand-parse-kind op)
- ((:argument :result)
- (let ((temp (operand-parse-temp op))
- (name (operand-parse-name op)))
- (cond ((and (operand-parse-load op) (operand-parse-scs op))
- (binds `(,(operand-parse-load-tn op)
- (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))))
- (t
- (binds `(,name (tn-ref-tn ,temp)))))))
- (:temporary
- (binds `(,(operand-parse-name op)
- (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))
- ,@(access-operands (vop-parse-results parse)
- (vop-parse-more-results parse)
- `(vop-results ,n-vop))
- ,@(access-operands (vop-parse-temps parse) nil
- `(vop-temps ,n-vop))
- ,@(when (vop-parse-info-args parse)
- `((,n-info (vop-codegen-info ,n-vop))
- ,@(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)))
- (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))))))
+ (ecase (operand-parse-kind op)
+ ((:argument :result)
+ (let ((temp (operand-parse-temp op))
+ (name (operand-parse-name op)))
+ (cond ((and (operand-parse-load op) (operand-parse-scs op))
+ (binds `(,(operand-parse-load-tn op)
+ (tn-ref-load-tn ,temp)))
+ (binds `(,name ,(decide-to-load parse op)))
+ (if (eq (operand-parse-kind op) :argument)
+ (loads (call-move-fun parse op t))
+ (saves (call-move-fun parse op nil))))
+ (t
+ (binds `(,name (tn-ref-tn ,temp)))))))
+ (:temporary
+ (binds `(,(operand-parse-name op)
+ (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))
+ ,@(access-operands (vop-parse-results parse)
+ (vop-parse-more-results parse)
+ `(vop-results ,n-vop))
+ ,@(access-operands (vop-parse-temps parse) nil
+ `(vop-temps ,n-vop))
+ ,@(when (vop-parse-info-args parse)
+ `((,n-info (vop-codegen-info ,n-vop))
+ ,@(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)))
+ (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))))))
\f
+(defvar *parse-vop-operand-count*)
+(defun make-operand-parse-temp ()
+ (without-package-locks
+ (intern (format nil "OPERAND-PARSE-TEMP-~D" *parse-vop-operand-count*)
+ (symbol-package '*parse-vop-operand-count*))))
+(defun make-operand-parse-load-tn ()
+ (without-package-locks
+ (intern (format nil "OPERAND-PARSE-LOAD-TN-~D" *parse-vop-operand-count*)
+ (symbol-package '*parse-vop-operand-count*))))
+
;;; 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.
;;; operand of the same name.
(defun !parse-vop-operands (parse specs kind)
(declare (list specs)
- (type (member :argument :result) kind))
+ (type (member :argument :result) kind))
(let ((num -1)
- (more nil))
+ (more nil))
(collect ((operands))
(dolist (spec specs)
- (unless (and (consp spec) (symbolp (first spec)) (oddp (length spec)))
- (error "malformed operand specifier: ~S" spec))
- (when more
- (error "The MORE operand isn't the last operand: ~S" specs))
- (let* ((name (first spec))
- (old (if (vop-parse-inherits parse)
- (find-operand name
- (vop-parse-or-lose
- (vop-parse-inherits parse))
- (list kind)
- nil)
- nil))
- (res (if old
- (make-operand-parse
- :name name
- :kind kind
- :target (operand-parse-target old)
- :born (operand-parse-born old)
- :dies (operand-parse-dies old)
- :scs (operand-parse-scs old)
- :load-tn (operand-parse-load-tn old)
- :load (operand-parse-load old))
- (ecase kind
- (:argument
- (make-operand-parse
- :name (first spec)
- :kind :argument
- :born (parse-time-spec :load)
- :dies (parse-time-spec `(:argument ,(incf num)))))
- (:result
- (make-operand-parse
- :name (first spec)
- :kind :result
- :born (parse-time-spec `(:result ,(incf num)))
- :dies (parse-time-spec :save)))))))
- (do ((key (rest spec) (cddr key)))
- ((null key))
- (let ((value (second key)))
- (case (first key)
- (:scs
- (aver (typep value 'list))
- (setf (operand-parse-scs res) (remove-duplicates value)))
- (:load-tn
- (aver (typep value 'symbol))
- (setf (operand-parse-load-tn res) value))
- (:load-if
- (setf (operand-parse-load res) value))
- (:more
- (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
- (aver (typep value 'symbol))
- (setf (operand-parse-target res) value))
- (:from
- (unless (eq kind :result)
- (error "can only specify :FROM in a result: ~S" spec))
- (setf (operand-parse-born res) (parse-time-spec value)))
- (:to
- (unless (eq kind :argument)
- (error "can only specify :TO in an argument: ~S" spec))
- (setf (operand-parse-dies res) (parse-time-spec value)))
- (t
- (error "unknown keyword in operand specifier: ~S" spec)))))
-
- (cond ((not more)
- (operands res))
- ((operand-parse-target more)
- (error "cannot specify :TARGET in a :MORE operand"))
- ((operand-parse-load more)
- (error "cannot specify :LOAD-IF in a :MORE operand")))))
+ (unless (and (consp spec) (symbolp (first spec)) (oddp (length spec)))
+ (error "malformed operand specifier: ~S" spec))
+ (when more
+ (error "The MORE operand isn't the last operand: ~S" specs))
+ (incf *parse-vop-operand-count*)
+ (let* ((name (first spec))
+ (old (if (vop-parse-inherits parse)
+ (find-operand name
+ (vop-parse-or-lose
+ (vop-parse-inherits parse))
+ (list kind)
+ nil)
+ nil))
+ (res (if old
+ (make-operand-parse
+ :name name
+ :kind kind
+ :target (operand-parse-target old)
+ :born (operand-parse-born old)
+ :dies (operand-parse-dies old)
+ :scs (operand-parse-scs old)
+ :load-tn (operand-parse-load-tn old)
+ :load (operand-parse-load old))
+ (ecase kind
+ (:argument
+ (make-operand-parse
+ :name (first spec)
+ :kind :argument
+ :born (parse-time-spec :load)
+ :dies (parse-time-spec `(:argument ,(incf num)))))
+ (:result
+ (make-operand-parse
+ :name (first spec)
+ :kind :result
+ :born (parse-time-spec `(:result ,(incf num)))
+ :dies (parse-time-spec :save)))))))
+ (do ((key (rest spec) (cddr key)))
+ ((null key))
+ (let ((value (second key)))
+ (case (first key)
+ (:scs
+ (aver (typep value 'list))
+ (setf (operand-parse-scs res) (remove-duplicates value)))
+ (:load-tn
+ (aver (typep value 'symbol))
+ (setf (operand-parse-load-tn res) value))
+ (:load-if
+ (setf (operand-parse-load res) value))
+ (:more
+ (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
+ (aver (typep value 'symbol))
+ (setf (operand-parse-target res) value))
+ (:from
+ (unless (eq kind :result)
+ (error "can only specify :FROM in a result: ~S" spec))
+ (setf (operand-parse-born res) (parse-time-spec value)))
+ (:to
+ (unless (eq kind :argument)
+ (error "can only specify :TO in an argument: ~S" spec))
+ (setf (operand-parse-dies res) (parse-time-spec value)))
+ (t
+ (error "unknown keyword in operand specifier: ~S" spec)))))
+
+ (cond ((not more)
+ (operands res))
+ ((operand-parse-target more)
+ (error "cannot specify :TARGET in a :MORE operand"))
+ ((operand-parse-load more)
+ (error "cannot specify :LOAD-IF in a :MORE operand")))))
(values (the list (operands)) more))))
\f
;;; 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))
+ (type vop-parse parse))
(let ((len (length spec)))
(unless (>= len 2)
(error "malformed temporary spec: ~S" spec))
(warn "temporary spec allocates no temps:~% ~S" spec))
(dolist (name (cddr spec))
(unless (symbolp name)
- (error "bad temporary name: ~S" name))
+ (error "bad temporary name: ~S" name))
+ (incf *parse-vop-operand-count*)
(let ((res (make-operand-parse :name name
- :kind :temporary
- :temp-temp (gensym)
- :born (parse-time-spec :load)
- :dies (parse-time-spec :save))))
- (do ((opt (second spec) (cddr opt)))
- ((null opt))
- (case (first opt)
- (:target
- (setf (operand-parse-target res)
- (vop-spec-arg opt 'symbol 1 nil)))
- (:sc
- (setf (operand-parse-sc res)
- (vop-spec-arg opt 'symbol 1 nil)))
- (:offset
- (let ((offset (eval (second opt))))
- (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...
- (:scs
- (let ((scs (vop-spec-arg opt 'list 1 nil)))
- (unless (= (length scs) 1)
- (error "must specify exactly one SC for a temporary"))
- (setf (operand-parse-sc res) (first scs))))
- (:type)
- (t
- (error "unknown temporary option: ~S" opt))))
-
- (unless (and (time-spec-order (operand-parse-dies res)
- (operand-parse-born res))
- (not (time-spec-order (operand-parse-born res)
- (operand-parse-dies res))))
- (error "Temporary lifetime doesn't begin before it ends: ~S" spec))
-
- (unless (operand-parse-sc res)
- (error "must specify :SC for all temporaries: ~S" spec))
-
- (setf (vop-parse-temps parse)
- (cons res
- (remove name (vop-parse-temps parse)
- :key #'operand-parse-name))))))
+ :kind :temporary
+ :born (parse-time-spec :load)
+ :dies (parse-time-spec :save))))
+ (do ((opt (second spec) (cddr opt)))
+ ((null opt))
+ (case (first opt)
+ (:target
+ (setf (operand-parse-target res)
+ (vop-spec-arg opt 'symbol 1 nil)))
+ (:sc
+ (setf (operand-parse-sc res)
+ (vop-spec-arg opt 'symbol 1 nil)))
+ (:offset
+ (let ((offset (eval (second opt))))
+ (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...
+ (:scs
+ (let ((scs (vop-spec-arg opt 'list 1 nil)))
+ (unless (= (length scs) 1)
+ (error "must specify exactly one SC for a temporary"))
+ (setf (operand-parse-sc res) (first scs))))
+ (:type)
+ (t
+ (error "unknown temporary option: ~S" opt))))
+
+ (unless (and (time-spec-order (operand-parse-dies res)
+ (operand-parse-born res))
+ (not (time-spec-order (operand-parse-born res)
+ (operand-parse-dies res))))
+ (error "Temporary lifetime doesn't begin before it ends: ~S" spec))
+
+ (unless (operand-parse-sc res)
+ (error "must specify :SC for all temporaries: ~S" spec))
+
+ (setf (vop-parse-temps parse)
+ (cons res
+ (remove name (vop-parse-temps parse)
+ :key #'operand-parse-name))))))
(values))
\f
-;;; the top-level parse function: clobber PARSE to represent the
+(defun compute-parse-vop-operand-count (parse)
+ (declare (type vop-parse parse))
+ (labels ((compute-count-aux (parse)
+ (declare (type vop-parse parse))
+ (if (null (vop-parse-inherits parse))
+ (length (vop-parse-operands parse))
+ (+ (length (vop-parse-operands parse))
+ (compute-count-aux
+ (vop-parse-or-lose (vop-parse-inherits parse)))))))
+ (if (null (vop-parse-inherits parse))
+ 0
+ (compute-count-aux (vop-parse-or-lose (vop-parse-inherits parse))))))
+
+;;; 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)
- (unless (consp spec)
- (error "malformed option specification: ~S" spec))
- (case (first spec)
- (:args
- (multiple-value-bind (fixed more)
- (!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-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))
- (:conditional
- (setf (vop-parse-result-types parse) ())
- (setf (vop-parse-results parse) ())
- (setf (vop-parse-more-results parse) nil)
- (setf (vop-parse-conditional-p parse) t))
- (:temporary
- (parse-temporary spec parse))
- (:generator
- (setf (vop-parse-cost parse)
- (vop-spec-arg spec 'unsigned-byte 1 nil))
- (setf (vop-parse-body parse) (cddr spec)))
- (:effects
- (setf (vop-parse-effects parse) (rest spec)))
- (:affected
- (setf (vop-parse-affected parse) (rest spec)))
- (:info
- (setf (vop-parse-info-args parse) (rest spec)))
- (:ignore
- (setf (vop-parse-ignores parse) (rest spec)))
- (:variant
- (setf (vop-parse-variant parse) (rest spec)))
- (:variant-vars
- (let ((vars (rest spec)))
- (setf (vop-parse-variant-vars parse) vars)
- (setf (vop-parse-variant parse)
- (make-list (length vars) :initial-element nil))))
- (:variant-cost
- (setf (vop-parse-cost parse) (vop-spec-arg spec 'unsigned-byte)))
- (:vop-var
- (setf (vop-parse-vop-var parse) (vop-spec-arg spec 'symbol)))
- (:move-args
- (setf (vop-parse-move-args parse)
- (vop-spec-arg spec '(member nil :local-call :full-call
- :known-return))))
- (:node-var
- (setf (vop-parse-node-var parse) (vop-spec-arg spec 'symbol)))
- (:note
- (setf (vop-parse-note parse) (vop-spec-arg spec '(or string null))))
- (:arg-types
- (setf (vop-parse-arg-types parse)
- (!parse-vop-operand-types (rest spec) t)))
- (:result-types
- (setf (vop-parse-result-types parse)
- (!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-ltn-policy parse)
- (vop-spec-arg spec 'ltn-policy)))
- (:save-p
- (setf (vop-parse-save-p parse)
- (vop-spec-arg spec
- '(member t nil :compute-only :force-to-stack))))
- (t
- (error "unknown option specifier: ~S" (first spec)))))
- (values))
+ (let ((*parse-vop-operand-count* (compute-parse-vop-operand-count parse)))
+ (dolist (spec specs)
+ (unless (consp spec)
+ (error "malformed option specification: ~S" spec))
+ (case (first spec)
+ (:args
+ (multiple-value-bind (fixed more)
+ (!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-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))
+ (:conditional
+ (setf (vop-parse-result-types parse) ())
+ (setf (vop-parse-results parse) ())
+ (setf (vop-parse-more-results parse) nil)
+ (setf (vop-parse-conditional-p parse) (or (rest spec) t)))
+ (:temporary
+ (parse-temporary spec parse))
+ (:generator
+ (setf (vop-parse-cost parse)
+ (vop-spec-arg spec 'unsigned-byte 1 nil))
+ (setf (vop-parse-body parse) (cddr spec)))
+ (:effects
+ (setf (vop-parse-effects parse) (rest spec)))
+ (:affected
+ (setf (vop-parse-affected parse) (rest spec)))
+ (:info
+ (setf (vop-parse-info-args parse) (rest spec)))
+ (:ignore
+ (setf (vop-parse-ignores parse) (rest spec)))
+ (:variant
+ (setf (vop-parse-variant parse) (rest spec)))
+ (:variant-vars
+ (let ((vars (rest spec)))
+ (setf (vop-parse-variant-vars parse) vars)
+ (setf (vop-parse-variant parse)
+ (make-list (length vars) :initial-element nil))))
+ (:variant-cost
+ (setf (vop-parse-cost parse) (vop-spec-arg spec 'unsigned-byte)))
+ (:vop-var
+ (setf (vop-parse-vop-var parse) (vop-spec-arg spec 'symbol)))
+ (:move-args
+ (setf (vop-parse-move-args parse)
+ (vop-spec-arg spec '(member nil :local-call :full-call
+ :known-return))))
+ (:node-var
+ (setf (vop-parse-node-var parse) (vop-spec-arg spec 'symbol)))
+ (:note
+ (setf (vop-parse-note parse) (vop-spec-arg spec '(or string null))))
+ (:arg-types
+ (setf (vop-parse-arg-types parse)
+ (!parse-vop-operand-types (rest spec) t)))
+ (:result-types
+ (setf (vop-parse-result-types parse)
+ (!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-ltn-policy parse)
+ (vop-spec-arg spec 'ltn-policy)))
+ (:save-p
+ (setf (vop-parse-save-p parse)
+ (vop-spec-arg spec
+ '(member t nil :compute-only :force-to-stack))))
+ (t
+ (error "unknown option specifier: ~S" (first spec)))))
+ (values)))
\f
;;;; making costs and restrictions
(defun compute-loading-costs (op load-p)
(declare (type operand-parse op))
(let ((scs (operand-parse-scs op))
- (costs (make-array sc-number-limit :initial-element nil))
- (load-scs (make-array sc-number-limit :initial-element nil)))
+ (costs (make-array sc-number-limit :initial-element nil))
+ (load-scs (make-array sc-number-limit :initial-element nil)))
(dolist (sc-name scs)
(let* ((load-sc (meta-sc-or-lose sc-name))
- (load-scn (sc-number load-sc)))
- (setf (svref costs load-scn) 0)
- (setf (svref load-scs load-scn) t)
- (dolist (op-sc (append (when load-p
- (sc-constant-scs load-sc))
- (sc-alternate-scs load-sc)))
- (let* ((op-scn (sc-number op-sc))
- (load (if load-p
- (aref (sc-load-costs load-sc) op-scn)
- (aref (sc-load-costs op-sc) load-scn))))
- (unless load
- (error "no move function defined to move ~:[from~;to~] SC ~
- ~S~%~:[to~;from~] alternate or constant SC ~S"
- load-p sc-name load-p (sc-name op-sc)))
-
- (let ((op-cost (svref costs op-scn)))
- (when (or (not op-cost) (< load op-cost))
- (setf (svref costs op-scn) load)))
-
- (let ((op-load (svref load-scs op-scn)))
- (unless (eq op-load t)
- (pushnew load-scn (svref load-scs op-scn))))))
-
- (dotimes (i sc-number-limit)
- (unless (svref costs i)
- (let ((op-sc (svref *backend-meta-sc-numbers* i)))
- (when op-sc
- (let ((cost (if load-p
- (svref (sc-move-costs load-sc) i)
- (svref (sc-move-costs op-sc) load-scn))))
- (when cost
- (setf (svref costs i) cost)))))))))
+ (load-scn (sc-number load-sc)))
+ (setf (svref costs load-scn) 0)
+ (setf (svref load-scs load-scn) t)
+ (dolist (op-sc (append (when load-p
+ (sc-constant-scs load-sc))
+ (sc-alternate-scs load-sc)))
+ (let* ((op-scn (sc-number op-sc))
+ (load (if load-p
+ (aref (sc-load-costs load-sc) op-scn)
+ (aref (sc-load-costs op-sc) load-scn))))
+ (unless load
+ (error "no move function defined to move ~:[from~;to~] SC ~
+ ~S~%~:[to~;from~] alternate or constant SC ~S"
+ load-p sc-name load-p (sc-name op-sc)))
+
+ (let ((op-cost (svref costs op-scn)))
+ (when (or (not op-cost) (< load op-cost))
+ (setf (svref costs op-scn) load)))
+
+ (let ((op-load (svref load-scs op-scn)))
+ (unless (eq op-load t)
+ (pushnew load-scn (svref load-scs op-scn))))))
+
+ (dotimes (i sc-number-limit)
+ (unless (svref costs i)
+ (let ((op-sc (svref *backend-meta-sc-numbers* i)))
+ (when op-sc
+ (let ((cost (if load-p
+ (svref (sc-move-costs load-sc) i)
+ (svref (sc-move-costs op-sc) load-scn))))
+ (when cost
+ (setf (svref costs i) cost)))))))))
(values costs load-scs)))
(defun compute-costs-and-restrictions-list (ops load-p)
(declare (list ops))
(collect ((costs)
- (scs))
+ (scs))
(dolist (op ops)
(multiple-value-bind (costs scs) (compute-loading-costs-if-any op load-p)
- (costs costs)
- (scs scs)))
+ (costs costs)
+ (scs scs)))
(values (costs) (scs))))
(defun make-costs-and-restrictions (parse)
(multiple-value-bind (arg-costs arg-scs)
(compute-costs-and-restrictions-list (vop-parse-args parse) t)
(multiple-value-bind (result-costs result-scs)
- (compute-costs-and-restrictions-list (vop-parse-results parse) nil)
+ (compute-costs-and-restrictions-list (vop-parse-results parse) nil)
`(
- :cost ,(vop-parse-cost parse)
-
- :arg-costs ',arg-costs
- :arg-load-scs ',arg-scs
- :result-costs ',result-costs
- :result-load-scs ',result-scs
-
- :more-arg-costs
- ',(if (vop-parse-more-args parse)
- (compute-loading-costs-if-any (vop-parse-more-args parse) t)
- nil)
-
- :more-result-costs
- ',(if (vop-parse-more-results parse)
- (compute-loading-costs-if-any (vop-parse-more-results parse) nil)
- nil)))))
+ :cost ,(vop-parse-cost parse)
+
+ :arg-costs ',arg-costs
+ :arg-load-scs ',arg-scs
+ :result-costs ',result-costs
+ :result-load-scs ',result-scs
+
+ :more-arg-costs
+ ',(if (vop-parse-more-args parse)
+ (compute-loading-costs-if-any (vop-parse-more-args parse) t)
+ nil)
+
+ :more-result-costs
+ ',(if (vop-parse-more-results parse)
+ (compute-loading-costs-if-any (vop-parse-more-results parse) nil)
+ nil)))))
\f
;;;; operand checking and stuff
(defun !parse-vop-operand-types (specs args-p)
(declare (list specs))
(labels ((parse-operand-type (spec)
- (cond ((eq spec '*) spec)
- ((symbolp spec)
- (let ((alias (gethash spec
- *backend-primitive-type-aliases*)))
- (if alias
- (parse-operand-type alias)
- `(:or ,spec))))
- ((atom spec)
- (error "bad thing to be a operand type: ~S" spec))
- (t
- (case (first spec)
- (:or
- (collect ((results))
- (results :or)
- (dolist (item (cdr spec))
- (unless (symbolp item)
- (error "bad PRIMITIVE-TYPE name in ~S: ~S"
- spec item))
- (let ((alias
- (gethash item
- *backend-primitive-type-aliases*)))
- (if alias
- (let ((alias (parse-operand-type alias)))
- (unless (eq (car alias) :or)
- (error "can't include primitive-type ~
- alias ~S in an :OR restriction: ~S"
- item spec))
- (dolist (x (cdr alias))
- (results x)))
- (results item))))
- (remove-duplicates (results)
- :test #'eq
- :start 1)))
- (:constant
- (unless args-p
- (error "can't :CONSTANT for a result"))
- (unless (= (length spec) 2)
- (error "bad :CONSTANT argument type spec: ~S" spec))
- spec)
- (t
- (error "bad thing to be a operand type: ~S" spec)))))))
+ (cond ((eq spec '*) spec)
+ ((symbolp spec)
+ (let ((alias (gethash spec
+ *backend-primitive-type-aliases*)))
+ (if alias
+ (parse-operand-type alias)
+ `(:or ,spec))))
+ ((atom spec)
+ (error "bad thing to be a operand type: ~S" spec))
+ (t
+ (case (first spec)
+ (:or
+ (collect ((results))
+ (results :or)
+ (dolist (item (cdr spec))
+ (unless (symbolp item)
+ (error "bad PRIMITIVE-TYPE name in ~S: ~S"
+ spec item))
+ (let ((alias
+ (gethash item
+ *backend-primitive-type-aliases*)))
+ (if alias
+ (let ((alias (parse-operand-type alias)))
+ (unless (eq (car alias) :or)
+ (error "can't include primitive-type ~
+ alias ~S in an :OR restriction: ~S"
+ item spec))
+ (dolist (x (cdr alias))
+ (results x)))
+ (results item))))
+ (remove-duplicates (results)
+ :test #'eq
+ :start 1)))
+ (:constant
+ (unless args-p
+ (error "can't :CONSTANT for a result"))
+ (unless (= (length spec) 2)
+ (error "bad :CONSTANT argument type spec: ~S" spec))
+ spec)
+ (t
+ (error "bad thing to be a operand type: ~S" spec)))))))
(mapcar #'parse-operand-type specs)))
-;;; Check the consistency of Op's Sc restrictions with the specified
+;;; 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.
;;;
(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)))
- (scs (operand-parse-scs op)))
+ (scs (operand-parse-scs op)))
(when scs
(multiple-value-bind (costs load-scs) (compute-loading-costs op load-p)
- (declare (ignore costs))
- (dolist (ptype ptypes)
- (unless (dolist (rep (primitive-type-scs
- (meta-primitive-type-or-lose ptype))
- nil)
- (when (svref load-scs rep) (return t)))
- (error "In the ~A ~:[result~;argument~] to VOP ~S,~@
- none of the SCs allowed by the operand type ~S can ~
- directly be loaded~@
- into any of the restriction's SCs:~% ~S~:[~;~@
- [* type operand must allow T's SCs.]~]"
- (operand-parse-name op) load-p (vop-parse-name parse)
- ptype
- scs (eq type '*)))))
+ (declare (ignore costs))
+ (dolist (ptype ptypes)
+ (unless (dolist (rep (primitive-type-scs
+ (meta-primitive-type-or-lose ptype))
+ nil)
+ (when (svref load-scs rep) (return t)))
+ (error "In the ~A ~:[result~;argument~] to VOP ~S,~@
+ none of the SCs allowed by the operand type ~S can ~
+ directly be loaded~@
+ into any of the restriction's SCs:~% ~S~:[~;~@
+ [* type operand must allow T's SCs.]~]"
+ (operand-parse-name op) load-p (vop-parse-name parse)
+ ptype
+ scs (eq type '*)))))
(dolist (sc scs)
- (unless (or (eq type '*)
- (dolist (ptype ptypes nil)
- (when (meta-sc-allowed-by-primitive-type
- (meta-sc-or-lose sc)
- (meta-primitive-type-or-lose ptype))
- (return t))))
- (warn "~:[Result~;Argument~] ~A to VOP ~S~@
- has SC restriction ~S which is ~
- not allowed by the operand type:~% ~S"
- load-p (operand-parse-name op) (vop-parse-name parse)
- sc type)))))
+ (unless (or (eq type '*)
+ (dolist (ptype ptypes nil)
+ (when (meta-sc-allowed-by-primitive-type
+ (meta-sc-or-lose sc)
+ (meta-primitive-type-or-lose ptype))
+ (return t))))
+ (warn "~:[Result~;Argument~] ~A to VOP ~S~@
+ has SC restriction ~S which is ~
+ not allowed by the operand type:~% ~S"
+ load-p (operand-parse-name op) (vop-parse-name parse)
+ sc type)))))
(values))
;;; against the number of defined operands.
(defun check-operand-types (parse ops more-op types load-p)
(declare (type vop-parse parse) (list ops)
- (type (or list (member :unspecified)) types)
- (type (or operand-parse null) more-op))
+ (type (or list (member :unspecified)) types)
+ (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)))
- types)
- num)
- (error "expected ~D ~:[result~;argument~] type~P: ~S"
- num load-p types num)))
+ (unless (= (count-if-not (lambda (x)
+ (and (consp x)
+ (eq (car x) :constant)))
+ types)
+ num)
+ (error "expected ~W ~:[result~;argument~] type~P: ~S"
+ num load-p types num)))
(when more-op
(let ((mtype (car (last types))))
- (when (and (consp mtype) (eq (first mtype) :constant))
- (error "can't use :CONSTANT on VOP more args")))))
+ (when (and (consp mtype) (eq (first mtype) :constant))
+ (error "can't use :CONSTANT on VOP more args")))))
(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))
- (if more-op (butlast ops) ops)
- (remove-if #'(lambda (x)
- (and (consp x)
- (eq (car x) ':constant)))
- (if more-op (butlast types) types)))))
+ (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)))
+ (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.
+;;; 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)
- (append (vop-parse-args parse)
- (if (vop-parse-more-args parse)
- (list (vop-parse-more-args parse)))
- (vop-parse-results parse)
- (if (vop-parse-more-results parse)
- (list (vop-parse-more-results parse)))
- (vop-parse-temps parse)))
+ (append (vop-parse-args parse)
+ (if (vop-parse-more-args parse)
+ (list (vop-parse-more-args parse)))
+ (vop-parse-results parse)
+ (if (vop-parse-more-results parse)
+ (list (vop-parse-more-results parse)))
+ (vop-parse-temps parse)))
(check-operand-types parse
- (vop-parse-args parse)
- (vop-parse-more-args parse)
- (vop-parse-arg-types parse)
- t)
+ (vop-parse-args parse)
+ (vop-parse-more-args parse)
+ (vop-parse-arg-types parse)
+ t)
(check-operand-types parse
- (vop-parse-results parse)
- (vop-parse-more-results parse)
- (vop-parse-result-types parse)
- nil)
+ (vop-parse-results parse)
+ (vop-parse-more-results parse)
+ (vop-parse-result-types parse)
+ nil)
(values))
\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
+;;; 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)
+(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)))))))
- (vop-parse-translate parse)))
+ (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
;;; restriction from the given specification.
(defun make-operand-type (type)
(cond ((eq type '*) ''*)
- ((symbolp type)
- ``(:or ,(primitive-type-or-lose ',type)))
- (t
- (ecase (first type)
- (:or
- ``(:or ,,@(mapcar #'(lambda (type)
- `(primitive-type-or-lose ',type))
- (rest type))))
- (:constant
- ``(:constant ,#'(lambda (x)
- (typep x ',(second type)))
- ,',(second type)))))))
+ ((symbolp type)
+ ``(:or ,(primitive-type-or-lose ',type)))
+ (t
+ (ecase (car type)
+ (:or
+ ``(:or ,,@(mapcar (lambda (type)
+ `(primitive-type-or-lose ',type))
+ (rest type))))
+ (:constant
+ ``(:constant ,#'(lambda (x)
+ ;; Can't handle SATISFIES during XC
+ ,(if (and (consp (second type))
+ (eq (caadr type) 'satisfies))
+ `(,(cadadr type) x)
+ `(sb!xc:typep x ',(second type))))
+ ,',(second type)))))))
(defun specify-operand-types (types ops more-ops)
(if (eq types :unspecified)
;;; 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)
- (vop-parse-args parse)
- more-args))
- (args (if more-args (butlast all-args) all-args))
- (more-arg (when more-args (car (last all-args))))
- (more-results (vop-parse-more-results parse))
- (all-results (specify-operand-types (vop-parse-result-types parse)
- (vop-parse-results parse)
- more-results))
- (results (if more-results (butlast all-results) all-results))
- (more-result (when more-results (car (last all-results))))
- (conditional (vop-parse-conditional-p parse)))
+ (all-args (specify-operand-types (vop-parse-arg-types parse)
+ (vop-parse-args parse)
+ more-args))
+ (args (if more-args (butlast all-args) all-args))
+ (more-arg (when more-args (car (last all-args))))
+ (more-results (vop-parse-more-results parse))
+ (all-results (specify-operand-types (vop-parse-result-types parse)
+ (vop-parse-results parse)
+ more-results))
+ (results (if more-results (butlast all-results) all-results))
+ (more-result (when more-results (car (last all-results))))
+ (conditional (vop-parse-conditional-p parse)))
`(: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
- :conditional
- `(list ,@(mapcar #'make-operand-type results)))
+ :result-types ,(cond ((eq conditional t)
+ :conditional)
+ (conditional
+ `'(:conditional . ,conditional))
+ (t
+ `(list ,@(mapcar #'make-operand-type results))))
:more-results-type ,(when more-results
- (make-operand-type more-result)))))
+ (make-operand-type more-result)))))
\f
;;;; setting up VOP-INFO
(defparameter *slot-inherit-alist*
'((:generator-function . vop-info-generator-function))))
-;;; This is something to help with inheriting VOP-Info slots. We
+;;; 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
+;;; 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
+;;; 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*))
- (error "unknown slot ~S" slot))
- (template-or-lose ',(vop-parse-name ,parse))))
+ (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
- (and iparse
- (equal (vop-parse-operands parse)
- (vop-parse-operands iparse))
- (equal (vop-parse-info-args iparse)
- (vop-parse-info-args parse))))
- (variant (vop-parse-variant parse)))
+ (and iparse
+ (equal (vop-parse-operands parse)
+ (vop-parse-operands iparse))
+ (equal (vop-parse-info-args iparse)
+ (vop-parse-info-args parse))))
+ (variant (vop-parse-variant parse)))
(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))
:ltn-policy ',(vop-parse-ltn-policy parse)
,@(make-costs-and-restrictions parse)
,@(make-emit-function-and-friends parse)
,@(inherit-vop-info :generator-function iparse
- (and same-operands
- (equal (vop-parse-body parse) (vop-parse-body iparse)))
- (unless (eq (vop-parse-body parse) :unspecified)
- (make-generator-function parse)))
+ (and same-operands
+ (equal (vop-parse-body parse) (vop-parse-body iparse)))
+ (unless (eq (vop-parse-body parse) :unspecified)
+ (make-generator-function parse)))
:variant (list ,@variant))))
\f
;;; Define the symbol NAME to be a Virtual OPeration in the compiler.
;;; keyword indicating the interpretation of the other forms in the
;;; SPEC:
;;;
-;;; :Args {(Name {Key Value}*)}*
-;;; :Results {(Name {Key Value}*)}*
+;;; :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.
+;;; :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-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
+;;; :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
+;;; 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
+;;; :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
+;;; :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
+;;; :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
+;;; :CONDITIONAL [Condition-descriptor+]
;;; 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
+;;; A side effect is to set the PREDICATE attribute for functions
;;; in the :TRANSLATE option.
;;;
-;;; :Temporary ({Key Value}*) Name*
+;;; If some condition descriptors are provided, this is a flag-setting
+;;; VOP. Descriptors are interpreted in an architecture-dependent
+;;; manner. See the BRANCH-IF VOP in $ARCH/pred.lisp.
+;;;
+;;; :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.
+;;; :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 omitted, 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).
+;;; :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*
+;;; :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
;;; During the evaluation of the body, the names of the operands
;;; and temporaries are bound to the actual TNs.
;;;
-;;; :Effects Effect*
-;;; :Affected Effect*
+;;; :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*
+;;; :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
+;;; 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).
+;;; for a function (specified by :TRANSLATE).
;;;
-;;; :Ignore Name*
+;;; :IGNORE Name*
;;; Causes the named variables to be declared IGNORE in the
;;; generator body.
;;;
-;;; :Variant Thing*
-;;; :Variant-Vars Name*
+;;; :VARIANT Thing*
+;;; :VARIANT-VARS Name*
;;; These options provide a way to parameterize families of VOPs
-;;; that differ only trivially. :Variant makes the specified
+;;; 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
+;;; :VARIANT-COST Cost
+;;; Specifies the cost of this VOP, overriding the cost of any
;;; inherited generator.
;;;
-;;; :Note {String | NIL}
+;;; :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.
+;;; :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*
+;;; :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}
+;;; :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.
+;;; :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
+;;; :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}
+;;; :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}
+;;; :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)
+(def!macro define-vop ((name &optional inherits) &body specs)
(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 inherited-parse)
- (make-vop-parse)))
- (n-res (gensym)))
+ (vop-parse-or-lose inherits)))
+ (parse (if inherits
+ (copy-vop-parse inherited-parse)
+ (make-vop-parse)))
+ (n-res (gensym)))
(setf (vop-parse-name parse) name)
(setf (vop-parse-inherits parse) inherits)
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
- (setf (gethash ',name *backend-parsed-vops*)
- ',parse))
+ (setf (gethash ',name *backend-parsed-vops*)
+ ',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))
+ (setf (gethash ',name *backend-template-names*) ,n-res)
+ (setf (template-type ,n-res)
+ (specifier-type (template-type-specifier ,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*
+;;; 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
+;;; 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
+;;; 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))
+ (binds))
(let ((n-head nil)
- (n-prev nil))
+ (n-prev nil))
(dolist (op fixed)
- (let ((n-ref (gensym)))
- (binds `(,n-ref (reference-tn ,op ,write-p)))
- (if n-prev
- (forms `(setf (tn-ref-across ,n-prev) ,n-ref))
- (setq n-head n-ref))
- (setq n-prev n-ref)))
+ (let ((n-ref (gensym)))
+ (binds `(,n-ref (reference-tn ,op ,write-p)))
+ (if n-prev
+ (forms `(setf (tn-ref-across ,n-prev) ,n-ref))
+ (setq n-head n-ref))
+ (setq n-prev n-ref)))
(when more
- (let ((n-more (gensym)))
- (binds `(,n-more ,more))
- (if n-prev
- (forms `(setf (tn-ref-across ,n-prev) ,n-more))
- (setq n-head n-more))))
+ (let ((n-more (gensym)))
+ (binds `(,n-more ,more))
+ (if n-prev
+ (forms `(setf (tn-ref-across ,n-prev) ,n-more))
+ (setq n-head n-more))))
(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.
+;;; 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)
- (let ((n-first (gensym))
- (n-last (gensym)))
- (once-only ((n-node node)
- (n-block block)
- (n-template template))
- `(multiple-value-bind (,n-first ,n-last)
- (funcall (template-emit-function ,n-template)
- ,n-node ,n-block ,n-template ,args ,results
- ,@(when info `(,info)))
- (insert-vop-sequence ,n-first ,n-last ,n-block nil)))))
+ `(emit-and-insert-vop ,node ,block ,template ,args ,results nil
+ ,@(when info `(,info))))
;;; 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
+;;; 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
+;;; 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.
+;;; 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)
(let* ((parse (vop-parse-or-lose name))
- (arg-count (length (vop-parse-args parse)))
- (result-count (length (vop-parse-results parse)))
- (info-count (length (vop-parse-info-args parse)))
- (noperands (+ arg-count result-count info-count))
- (n-node (gensym))
- (n-block (gensym))
- (n-template (gensym)))
+ (arg-count (length (vop-parse-args parse)))
+ (result-count (length (vop-parse-results parse)))
+ (info-count (length (vop-parse-info-args parse)))
+ (noperands (+ arg-count result-count info-count))
+ (n-node (gensym))
+ (n-block (gensym))
+ (n-template (gensym)))
(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"
- (length operands) noperands))
+ (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)
+ (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)))
- (let ((temp (gensym)))
- (ibinds `(,temp ,info))
- (ivars temp)))
-
- `(let* ((,n-node ,node)
- (,n-block ,block)
- (,n-template (template-or-lose ',name))
- ,@abinds
- ,@(ibinds)
- ,@rbinds)
- ,@acode
- ,@rcode
- (emit-template ,n-node ,n-block ,n-template ,n-args
- ,n-results
- ,@(when (ivars)
- `((list ,@(ivars)))))
- (values)))))))
+ (make-operand-list (subseq operands (+ arg-count info-count)) nil t)
+
+ (collect ((ibinds)
+ (ivars))
+ (dolist (info (subseq operands arg-count (+ arg-count info-count)))
+ (let ((temp (gensym)))
+ (ibinds `(,temp ,info))
+ (ivars temp)))
+
+ `(let* ((,n-node ,node)
+ (,n-block ,block)
+ (,n-template (template-or-lose ',name))
+ ,@abinds
+ ,@(ibinds)
+ ,@rbinds)
+ ,@acode
+ ,@rcode
+ (emit-template ,n-node ,n-block ,n-template ,n-args
+ ,n-results
+ ,@(when (ivars)
+ `((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.
+;;; using already-created TN-REF lists.
;;;
-;;; The Arguments and Results are TNs to be referenced as the first
+;;; 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
+;;; 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
+;;; As with VOP, the INFO forms are evaluated and passed as codegen
;;; info arguments.
(defmacro vop* (name node block args results &rest info)
(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)))
- (info-count (length (vop-parse-info-args parse)))
- (fixed-args (butlast args))
- (fixed-results (butlast results))
- (n-node (gensym))
- (n-block (gensym))
- (n-template (gensym)))
+ (arg-count (length (vop-parse-args parse)))
+ (result-count (length (vop-parse-results parse)))
+ (info-count (length (vop-parse-info-args parse)))
+ (fixed-args (butlast args))
+ (fixed-results (butlast results))
+ (n-node (gensym))
+ (n-block (gensym))
+ (n-template (gensym)))
(unless (or (vop-parse-more-args parse)
- (<= (length fixed-args) arg-count))
+ (<= (length fixed-args) arg-count))
(error "too many fixed arguments"))
(unless (or (vop-parse-more-results parse)
- (<= (length fixed-results) result-count))
+ (<= (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)
+ (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))
- ,@abinds
- ,@rbinds)
- ,@acode
- ,@rcode
- (emit-template ,n-node ,n-block ,n-template ,n-args ,n-results
- ,@(when info
- `((list ,@info))))
- (values))))))
+ (make-operand-list fixed-results (car (last results)) t)
+
+ `(let* ((,n-node ,node)
+ (,n-block ,block)
+ (,n-template (template-or-lose ',name))
+ ,@abinds
+ ,@rbinds)
+ ,@acode
+ ,@rcode
+ (emit-template ,n-node ,n-block ,n-template ,n-args ,n-results
+ ,@(when info
+ `((list ,@info))))
+ (values))))))
\f
;;;; miscellaneous macros
;;; 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)
+(def!macro sc-case (tn &body forms)
(let ((n-sc (gensym))
- (n-tn (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
- (sc-name (tn-sc ,n-tn))))))
- (let ((case (first cases)))
- (when (atom 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."))
- (clauses `(t nil ,@(rest case)))
- (return))
- (clauses `((or ,@(mapcar #'(lambda (x)
- `(eql ,(meta-sc-number-or-lose x)
- ,n-sc))
- (if (atom head) (list head) head)))
- nil ,@(rest case))))))
+ ((null cases)
+ (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))
+ (let ((head (first case)))
+ (when (eq head t)
+ (when (rest cases)
+ (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))
+ (if (atom head) (list head) head)))
+ nil ,@(rest case))))))
`(let* ((,n-tn ,tn)
- (,n-sc (sc-number (tn-sc ,n-tn))))
- (cond ,@(clauses))))))
+ (,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)
(once-only ((n-sc `(sc-number (tn-sc ,tn))))
- `(or ,@(mapcar #'(lambda (x)
- `(eql ,n-sc ,(meta-sc-number-or-lose x)))
- scs))))
+ `(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)
+ &body forms)
`(do ((,block-var (block-info (component-head ,component))
- (ir2-block-next ,block-var)))
+ (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
+;;; 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)
- (let ((n-conf (gensym))
- (n-bod (gensym))
- (i (gensym))
- (ltns (gensym)))
+ (with-unique-names (conf bod i ltns)
(once-only ((n-live live)
- (n-block block))
+ (n-block block))
`(block nil
- (flet ((,n-bod (,tn-var) ,@body))
- ;; Do component-live TNs.
- (dolist (,tn-var (ir2-component-component-tns
- (component-info
- (block-component
- (ir2-block-block ,n-block)))))
- (,n-bod ,tn-var))
-
- (let ((,ltns (ir2-block-local-tns ,n-block)))
- ;; 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)))
- ((null ,n-conf))
- (when (or (eq (global-conflicts-kind ,n-conf) :live)
- (let ((,i (global-conflicts-number ,n-conf)))
- (and (eq (svref ,ltns ,i) :more)
- (not (zerop (sbit ,n-live ,i))))))
- (,n-bod (global-conflicts-tn ,n-conf))))
- ;; Do TNs locally live in the designated live set.
- (dotimes (,i (ir2-block-local-tn-count ,n-block) ,result)
- (unless (zerop (sbit ,n-live ,i))
- (let ((,tn-var (svref ,ltns ,i)))
- (when (and ,tn-var (not (eq ,tn-var :more)))
- (,n-bod ,tn-var)))))))))))
+ (flet ((,bod (,tn-var) ,@body))
+ ;; Do component-live TNs.
+ (dolist (,tn-var (ir2-component-component-tns
+ (component-info
+ (block-component
+ (ir2-block-block ,n-block)))))
+ (,bod ,tn-var))
+
+ (let ((,ltns (ir2-block-local-tns ,n-block)))
+ ;; Do TNs always-live in this block and live :MORE TNs.
+ (do ((,conf (ir2-block-global-tns ,n-block)
+ (global-conflicts-next-blockwise ,conf)))
+ ((null ,conf))
+ (when (or (eq (global-conflicts-kind ,conf) :live)
+ (let ((,i (global-conflicts-number ,conf)))
+ (and (eq (svref ,ltns ,i) :more)
+ (not (zerop (sbit ,n-live ,i))))))
+ (,bod (global-conflicts-tn ,conf))))
+ ;; Do TNs locally live in the designated live set.
+ (dotimes (,i (ir2-block-local-tn-count ,n-block) ,result)
+ (unless (zerop (sbit ,n-live ,i))
+ (let ((,tn-var (svref ,ltns ,i)))
+ (when (and ,tn-var (not (eq ,tn-var :more)))
+ (,bod ,tn-var)))))))))))
;;; Iterate over all the IR2 blocks in PHYSENV, in emit order.
(defmacro do-physenv-ir2-blocks ((block-var physenv &optional result)
- &body body)
+ &body body)
(once-only ((n-physenv physenv))
- (once-only ((n-first `(node-block
- (lambda-bind
- (physenv-function ,n-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-physenv ,block-var) ,n-physenv)))
- ,result)
- ,@body)))))
+ (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-physenv ,block-var) ,n-physenv)))
+ ,result)
+ ,@body)))))
projects / sbcl.git / blobdiff