Forked from
cmucl / cmucl
13795 commits behind the upstream repository.
vmdef.lisp 64.63 KiB
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; This file contains implementation-independent facilities used for
;;; defining the compiler's interface to the VM in a given implementation.
;;;
;;; Written by Rob MacLachlan
;;;
(in-package 'c)
;;;
;;; Translates from SC numbers to SC info structures. SC numbers are always
;;; used instead of names at run time, so changing this vector changes all the
;;; references.
(defvar *sc-numbers* (make-array sc-number-limit))
(proclaim '(type sc-vector *sc-numbers*))
;;;
;;; A list of all the SBs defined, so that we can easily iterate over them.
(defvar *sb-list* ())
(proclaim '(type list *sb-list*))
;;;
;;; Translates from template names to template structures.
(defvar *template-names* (make-hash-table :test #'eq))
(proclaim '(type hash-table *template-names*))
;;; Template-Or-Lose -- Internal
;;;
;;; Return the template having the specified name, or die trying.
;;;
(defun template-or-lose (x)
(the template
(or (gethash x *template-names*)
(error "~S is not a defined template." x))))
(eval-when (compile load eval)
;;;
;;; Hashtable from SC and SB names the corresponding structures. These tables
;;; are only used at meta-compile and load times, so the defining macros can
;;; change these at meta-compile time without breaking the compiler.
(defvar *sc-names* (make-hash-table :test #'eq))
(defvar *sb-names* (make-hash-table :test #'eq))
(proclaim '(hash-table *sc-names* *sb-names*))
;;;
;;; Like *SC-Numbers*, but is updated at meta-compile time.
(defvar *meta-sc-numbers* (make-array sc-number-limit))
(proclaim '(type sc-vector *meta-sc-numbers*))
;;; SC-Or-Lose, SB-Or-Lose, SC-Number-Or-Lose -- Internal
;;;
;;; Return the SC structure, SB structure or SC number corresponding to a
;;; name, or die trying. These should not be used after load time, since
;;; compiling the compiler changes the definitions.
;;;
(defun sc-or-lose (x)
(the sc
(or (gethash x *sc-names*)
(error "~S is not a defined storage class." x))))
;;;
(defun sb-or-lose (x)
(the sb
(or (gethash x *sb-names*)
(error "~S is not a defined storage base." x))))
;;;
(defun sc-number-or-lose (x)
(the sc-number (sc-number (sc-or-lose x))))
); Eval-When (Compile Load Eval)
;;;; Storage class and storage base definition:
;;; Define-Storage-Base -- Public
;;;
;;; 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)
"Define-Storage-Base Name Kind {Key Value}*
Define a storage base having the specified Name. Kind may be :Finite,
:Unbounded or :Non-Packed. The following keywords are legal:
:Size <Size>
Specify the number of locations in a :Finite SB or the initial size of a
:Unbounded SB."
(check-type name symbol)
(check-type kind (member :finite :unbounded :non-packed))
(ecase kind
(:non-packed
(when size
(error "Size specification meaningless in a ~S SB." kind)))
((:finite :unbounded)
(unless size (error "Size not specified in a ~S SB." kind))
(check-type size unsigned-byte)))
(let ((res (if (eq kind :non-packed)
(make-sb :name name :kind kind)
(make-finite-sb :name name :kind kind :size size))))
`(progn
(eval-when (compile load eval)
(setf (gethash ',name *sb-names*) ',res))
,(if (eq kind :non-packed)
`(setf (gethash ',name *sb-names*) (copy-sb ',res))
`(let ((res (copy-finite-sb ',res)))
(setf (finite-sb-always-live res)
(make-array ',size :initial-element #*))
(setf (finite-sb-conflicts res)
(make-array ',size :initial-element '#()))
(setf (finite-sb-live-tns res)
(make-array ',size :initial-element nil))
(setf (gethash ',name *sb-names*) res)))
(setq *sb-list*
(cons (gethash ',name *sb-names*)
(remove ',name *sb-list* :key #'sb-name)))
',name)))
;;; Define-Storage-Class -- Public
;;;
;;;
(defmacro define-storage-class (name number sb-name &key (element-size '1)
locations)
"Define-Storage-Class Name Number Storage-Base {Key Value}*
Define a storage class Name that uses the named Storage-Base. Number is a
small, non-negative integer that is used as an alias. The following
keywords are defined:
:Element-Size <Size>
The size of objects in this SC in whatever units the SB uses. This
defaults to 1.
:Locations
If the SB is :Finite, then this is a list of the offsets within the SB
that are in this SC."
(check-type name symbol)
(check-type number sc-number)
(check-type sb-name symbol)
(check-type locations list)
(let ((sb (sb-or-lose sb-name)))
(if (eq (sb-kind sb) :finite)
(let ((size (sb-size sb))
(element-size (eval element-size)))
(check-type element-size unsigned-byte)
(dolist (el locations)
(check-type el unsigned-byte)
(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)))))
`(progn
(eval-when (compile load eval)
(setf (gethash ',name *sc-names*)
(make-sc :name ',name :number ',number
:sb (sb-or-lose ',sb-name)
:element-size ,element-size
:locations ',locations)))
(eval-when (compile eval)
(setf (svref *meta-sc-numbers* ',number)
(gethash ',name *sc-names*)))
(let ((old (svref *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)))
(setf (svref *sc-numbers* ',number) (sc-or-lose ',name))
',name))
;;;; Primitive type definition:
;;; Translates from primitive type names to the corresponding primitive-type
;;; structure.
;;;
(defvar *primitive-type-names* (make-hash-table :test #'eq))
;;; The primitive type T is somewhat magical, in that it is the only primitive
;;; type that overlaps with other primitive types. An object of primitive-type
;;; T is in the canonical descriptor (boxed or pointer) representation.
;;;
;;; We stick the T primitive-type in a variable so that people who have to
;;; special-case it can get at it conveniently. This is done by the machine
;;; specific VM definition, since the Def-Primitive-Type for T must specify the
;;; SCs that boxed objects can be allocated in.
;;;
(proclaim '(special *any-primitive-type*))
(proclaim '(type primitive-type *any-primitive-type*))
;;; Def-Primitive-Type -- Public
;;;
;;; If the primitive-type structure already exists, we destructively modify
;;; it so that existing references in templates won't be invalidated.
;;; Primitive-type definition isn't done at meta-compile time, so this doesn't
;;; break the running compiler.
;;;
(defmacro def-primitive-type (name scs &key (type name))
"Def-Primitive-Type Name (SC*) {Key Value}*
Define a primitive type Name. Each SC specifies a Storage Class that values
of this type may be allocated in. The following keyword options are defined:
:Type
The type descriptor for the Lisp type that is equivalent to this type
(defaults to Name.)"
(check-type name symbol)
(check-type scs list)
(once-only ((n-old `(gethash ',name *primitive-type-names*))
(n-scs `(mapcar #'sc-number-or-lose ',scs))
(n-type `(specifier-type ',type)))
`(progn
(cond (,n-old
(setf (primitive-type-scs ,n-old) ,n-scs)
(setf (primitive-type-type ,n-old) ,n-type))
(t
(setf (gethash ',name *primitive-type-names*)
(make-primitive-type :name ',name
:scs ,n-scs
:type ,n-type))))
',name)))
;;; Primitive-Type-Or-Lose -- Interface
;;;
;;; Return the primitive type corresponding to the spesicifed name, or die
;;; trying.
;;;
(defun primitive-type-or-lose (name)
(the primitive-type
(or (gethash name *primitive-type-names*)
(error "~S is not a defined primitive type." name))))
;;; Primitive-Subtypep -- Interface
;;;
;;; Return true if the primitive type Type1 is a subtype of the primitive
;;; type Type2. This is only true if the types are identical or if Type2 is T.
;;;
(proclaim '(inline primitive-subtypep))
(defun primitive-subtypep (type1 type2)
(declare (type primitive-type type1 type2))
(or (eq type1 type2) (eq type2 *any-primitive-type*)))
;;; Primitive-Type-Union -- Interface
;;;
;;; Return the union of two primitive types.
;;;
(proclaim '(inline primitive-type-union))
(defun primitive-type-union (type1 type2)
(declare (type primitive-type type1 type2))
(if (eq type1 type2)
type1
*any-primitive-type*))
(eval-when (compile load eval)
(defparameter primitive-type-slot-alist
'((:coerce-to-t . primitive-type-coerce-to-t)
(:coerce-from-t . primitive-type-coerce-from-t)
(:move . primitive-type-move)
(:check . primitive-type-check))))
;;; Primitive-Type-Vop -- Public
;;;
(defmacro primitive-type-vop (vop kinds &rest types)
"Primitive-Type-VOP Vop (Kind*) Type*
Annotate all the specified primitive Types with the named VOP under each of
the specified kinds:
:Coerce-To-T
:Coerce-From-T
:Move
One argument one result VOPs used for coercion between representations
and explicit moves.
:Check
A one argument one result VOP that moves the argument to the result,
checking that the value is of this type in the process."
(let ((n-vop (gensym))
(n-type (gensym)))
`(let ((,n-vop (template-or-lose ',vop)))
,@(mapcar
#'(lambda (type)
`(let ((,n-type (primitive-type-or-lose ',type)))
,@(mapcar
#'(lambda (kind)
(let ((slot (or (cdr (assoc kind
primitive-type-slot-alist))
(error "Unknown kind: ~S." kind))))
`(setf (,slot ,n-type) ,n-vop)))
kinds)))
types)
nil)))
;;;; Move cost definition:
;;;
;;; A 2-d array indexed by the source and destination SC number resulting in
;;; the cost of doing that move. If a cost for an entry wasn't specified, then
;;; the entry is null. This is initalized by a use of Define-Move-Costs in the
;;; VM definition, and is used by Define-VOP at meta-compile time to fill in
;;; the costs for SCs not explicitly handled.
(defvar *move-costs*)
;;; Define-Move-Costs -- Public
;;;
;;; Build the *move-costs* array, doing some basic consistency checking.
;;;
(defmacro define-move-costs (&rest specs)
"Define-Move-Costs {((Source-SC*) {(Cost Dest-SC*)}*)}*
This macro declares the cost of the implicit move operations needed to load
arguments and store results. The format is somewhat similar to the costs
specifications in Define-VOP. Each argument form gives the cost for moving
to all possible destination SCs from some collection of equivalent source
SCs.
This information is used only to compute the cost of moves from arguments to
Load TNs or from Load TNs to results. It is not necessary to specify the
costs for moves between combinations of SCs impossible in this context."
(let ((res (make-array (list sc-number-limit sc-number-limit)
:initial-element nil)))
(dolist (spec specs)
(unless (and (every #'listp spec)
(>= (length spec) 2))
(error "Malformed move cost specification: ~S." spec))
(dolist (dest-spec (rest spec))
(unless (and (>= (length dest-spec) 2)
(typep (first dest-spec) 'unsigned-byte))
(error "Malformed move destination cost specification: ~S."
dest-spec))
(let ((cost (first dest-spec)))
(dolist (dest-sc (rest dest-spec))
(let ((dest-scn (sc-number-or-lose dest-sc)))
(dolist (source-sc (first spec))
(setf (aref res (sc-number-or-lose source-sc) dest-scn)
cost)))))))
`(progn
(eval-when (compile load eval)
(setq *move-costs* ',res))
(dotimes (i sc-number-limit)
(dotimes (j sc-number-limit)
(when (and (aref *move-costs* i j) (not (aref *move-costs* j i))
(not (eq (sb-kind (sc-sb (svref *sc-numbers* i)))
:non-packed)))
(warn "Move possible from SC ~D to ~D, but not vice-versa."
i j)))))))
;;; A SC-Vector containing the SCs used for saving each SC, or NIL if the SC
;;; isn't saved.
;;;
(defvar *save-scs* (make-array sc-number-limit :initial-element nil))
;;; Cost vectors describing the costs of saving and restoring TNs in each SC.
;;; Zero for SCs that aren't saved.
;;;
(defvar *save-costs*)
(defvar *restore-costs*)
;;; Define-Save-SCs -- Interface
;;;
(defmacro define-save-scs (&rest specs)
"Define-Save-SCs {(save-sc saved-sc*)}*
This form is used to define which SCs must be saved on a function call. The
Saved-SCs are SCs that must be saved. The Save-SC a SC that is used in
combination with the defined move costs to determine the cost of saving."
(let ((save-costs (make-array sc-number-limit :initial-element 0))
(restore-costs (make-array sc-number-limit :initial-element 0)))
(collect ((scs)
(saves))
(dolist (spec specs)
(let ((save-scn (sc-number-or-lose (first spec))))
(dolist (sc (rest spec))
(let ((saved-scn (sc-number-or-lose sc)))
(when (member saved-scn (scs))
(error "SC ~S appears more than once." sc))
(scs saved-scn)
(saves save-scn)
(setf (svref save-costs saved-scn)
(aref *move-costs* saved-scn save-scn))
(setf (svref restore-costs saved-scn)
(aref *move-costs* save-scn saved-scn))))))
`(progn
,@(mapcar #'(lambda (scn save)
`(setf (svref *save-scs* ,scn)
(svref *sc-numbers* ,save)))
(scs) (saves))
(setq *save-costs* ',save-costs)
(setq *restore-costs* ',restore-costs)
nil))))
;;;; VOP definition structures:
;;;
;;; Define-VOP uses some fairly complex data structures at meta-compile
;;; time, both to hold the results of parsing the elaborate syntax and to
;;; retain the information so that it can be inherited by other VOPs.
(eval-when (compile load eval)
;;;
;;; Hashtable translating from VOP names to the corresponding VOP-Parse
;;; structures. This information is only used at meta-compile time.
(defvar *parsed-vops* (make-hash-table :test #'eq))
(proclaim '(type hash-table *parsed-vops*))
;;; The VOP-Parse structure holds everything we need to know about a VOP at
;;; meta-compile time.
;;;
(defstruct (vop-parse
(:print-function %print-vop-parse))
;;
;; The name of this VOP.
(name nil :type symbol)
;;
;; If true, then the name of the VOP we inherit from.
(inherits nil :type (or symbol null))
;;
;; Lists of Operand-Parse structures describing the arguments, results and
;; temporaries of the VOP.
(args nil :type list)
(results nil :type list)
(temps nil :type list)
;;
;; Operand-Parse structures containing information about more args and
;; results. If null, then there there are no more operands of that kind.
(more-args nil :type (or operand-parse null))
(more-results nil :type (or operand-parse null))
;;
;; A list of all the above together.
(operands nil :type list)
;;
;; Names of variables that should be declared ignore.
(ignores () :type list)
;;
;; True if this is a :Conditional VOP.
(conditional-p nil)
;;
;; Argument and result primitive types. These are pulled out of the
;; operands, since we often want to change them without respecifying the
;; operands.
(arg-types :unspecified :type (or (member :unspecified) list))
(result-types :unspecified :type (or (member :unspecified) list))
;;
;; The guard expression specified, or NIL if none.
(guard nil)
;;
;; The cost of and body code for the generator.
(cost 0 :type unsigned-byte)
(body :unspecified :type (or (member :unspecified) list))
;;
;; Info for VOP variants. The list of forms to be evaluated to get the
;; variant args for this VOP, and the list of variables to be bound to the
;; variant args.
(variant () :type list)
(variant-vars () :type list)
;;
;; Variable bound to the Vop-Node when in the generator body.
(node-var nil :type (or symbol null))
;;
;; A list of the names of the codegen-info arguments to this VOP.
(info-args () :type list)
;;
;; An efficiency note associated with this VOP.
(note nil :type (or string null))
;;
;; A list of the names of the Effects and Affected attributes for this VOP.
(effects '(any) :type list)
(affected '(any) :type list)
;;
;; A list of the names of functions this VOP is a translation of and the
;; policy that allows this translation to be done. :Fast is a safe default,
;; since it isn't a safe policy.
(translate () :type list)
(policy :fast :type policies)
;;
;; Stuff used by life analysis.
(save-p nil :type (member t nil :force-to-stack)))
(defprinter vop-parse
name
(inherits :test inherits)
args
results
temps
(more-args :test more-args)
(more-results :test more-results)
(conditional-p :test conditional-p)
ignores
arg-types
result-types
cost
body
(variant :test variant)
(variant-vars :test variant-vars)
(info-args :test info-args)
(note :test note)
effects
affected
translate
policy)
;;; The Operand-Parse structure contains stuff we need to know about and
;;; operand or temporary at meta-compile time. Besides the obvious stuff, we
;;; also store the names of per-operand temporaries here.
;;;
(defstruct (operand-parse
(:print-function %print-operand-parse))
;;
;; Name of the operand (which we bind to the TN).
(name nil :type symbol)
;;
;; The way this operand is used:
(kind nil :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))
;;
;; Temporary that holds the TN-Ref for this operand. Temp-Temp holds the
;; write reference that begins a temporary's lifetime.
(temp (gensym) :type symbol)
(temp-temp nil :type (or symbol null))
;;
;; The time that this operand is first live and the time at which it becomes
;; dead again. These are time-specs, as returned by parse-time-spec.
born
dies
;;
;; A list of the names of the SCs that this operand is allowed into. If
;; false, there is no restriction.
(scs nil :type list)
;;
;; True if automatic operand loading should be done when the SC restriction
;; isn't met. Meaningful only in arguments and results.
(load t :type boolean)
;;
;; The primitive-type of a temporary.
(type t :type symbol)
;;
;; In a wired temporary this is the SC and offset it is wired to.
(sc nil :type (or symbol null))
(offset nil :type (or unsigned-byte null)))
(defprinter operand-parse
name
kind
(type :test (not (eq type t)))
(target :test target)
born
dies
(scs :test scs)
load
(sc :test sc)
(offset :test offset))
); Eval-When (Compile Load Eval)
;;;; Random utilities:
(eval-when (compile load eval)
;;; Find-Operand -- Internal
;;;
;;; Find the operand or temporary with the specifed Name in the VOP Parse.
;;; If there is no such operand, signal an error. Also error if the operand
;;; kind isn't one of the specified Kinds.
;;;
(defun find-operand (name parse &optional
(kinds '(:argument :result :temporary)))
(declare (symbol name) (type vop-parse parse) (list kinds))
(let ((found (find name (vop-parse-operands parse)
:key #'operand-parse-name)))
(unless found
(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))
found))
;;; VOP-Parse-Or-Lose -- Internal
;;;
;;; 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 *parsed-vops*)
(error "~S is not the name of a defined VOP." name))))
;;; Access-Operands -- Internal
;;;
;;; Return a list of let-forms to parse a tn-ref list into a the temps
;;; specified by the operand-parse structures. More-Operand is the
;;; Operand-Parse describing any more operand, or NIL if none. Refs is an
;;; expression that evaluates into the first tn-ref.
;;;
(defun access-operands (operands more-operand refs)
(declare (list operands refs))
(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))))
(when more-operand
(res `(,(operand-parse-name more-operand) ,prev))))
(res)))
;;; Ignore-Unreferenced-Temps -- Internal
;;;
;;; Used with Access-Operands to prevent warnings for TN-Ref temps not used
;;; by some particular function. It returns the name of the last operand, or
;;; NIL if Operands is NIL.
;;;
(defun ignore-unreferenced-temps (operands)
(when operands
(operand-parse-temp (car (last operands)))))
;;; VOP-Spec-Arg -- Internal
;;;
;;; Grab an arg out of a VOP spec, checking the type and syntax and stuff.
;;;
(defun vop-spec-arg (spec type &optional (n 1) (last t))
(let ((len (length spec)))
(when (<= len n)
(error "~:R argument missing: ~S." n spec))
(when (and last (> len (1+ n)))
(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))
thing)))
;;;; Time specs:
;;; Parse-Time-Spec -- Internal
;;;
;;; Return a time spec describing a time during the evaluation of a VOP,
;;; used to delimit operand and temporary lifetimes. The representation is a
;;; cons whose CAR is the number of the evaluation phase and the CDR is the
;;; sub-phase. The sub-phase is 0 in the :Load and :Save phases.
;;;
(defun parse-time-spec (spec)
(let ((dspec (if (atom spec) (list spec 0) spec)))
(unless (and (= (length dspec) 2)
(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))))
;;; Time-Spec-Order -- Internal
;;;
;;; 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)))))
;;;; Emit function generation:
;;; Compute-Reference-Order -- Internal
;;;
;;; Return a list of 2-lists (<Temporary> <More-P>) in reverse reference
;;; order describing how to build the next-ref linkage for Parse. If More-P is
;;; false, then the Temporary points to a single TN-Ref that should be linked
;;; in. If More-P is true, then Temporary points to a chain of Tn-Refs linked
;;; together by Tn-Ref-Across that should be linked in reverse order.
;;;
;;; In implementation, we build a temporary list containing the result
;;; tuples augmented with reference time and whether the reference is a write.
;;; We sort this list using Time-Spec-Order augmented by the subsidiary rule
;;; that when the specs are equal, we do read references first. This
;;; implements the desired semantics of open intervals for temporary lifetimes.
;;;
(defun compute-reference-order (parse)
(declare (type vop-parse parse))
(collect ((refs))
(dolist (op (vop-parse-operands parse))
(let ((born (operand-parse-born op))
(dies (operand-parse-dies op))
(name (operand-parse-name op))
(temp (operand-parse-temp op))
(temp-temp (operand-parse-temp-temp op)))
(ecase (operand-parse-kind op)
(:argument
(refs (list (cons dies nil) temp nil)))
(:more-argument
(refs (list (cons dies nil) name t)))
(:result
(refs (list (cons born t) temp nil)))
(:more-result
(refs (list (cons born t) name t)))
(:temporary
(refs (list (cons born t) temp nil))
(refs (list (cons dies nil) temp-temp nil))))))
(mapcar #'cdr
(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)
(or (cdr x) (not (cdr y)))
t)
nil)))
:key #'first))))
;;; Make-Next-Ref-Linkage -- Internal
;;;
;;; Use the operand lifetime annotations to set up the next-ref slots in all
;;; the TN-Refs used in the VOP. We set the Refs in the VOP to point to the
;;; head of this list. More operands make life a bit interesting, since they
;;; introduce uncertainty as to whether we have seen any operands yet, and also
;;; must be linked together contiguously with the other TN-Refs.
;;;
(defun make-next-ref-linkage (parse n-vop)
(declare (type vop-parse parse))
(collect ((forms)
(binds))
(let ((first-seen :no)
(prev nil))
(dolist (x (compute-reference-order parse))
(let* ((var (first x))
(more-p (second x))
(n-tail (if more-p (gensym) var)))
(ecase first-seen
(:no
(forms `(setf (vop-refs ,n-vop) ,n-tail)))
(:yes
(forms `(setf (tn-ref-next-ref ,prev) ,n-tail)))
(:maybe
(forms `(if ,prev
(setf (tn-ref-next-ref ,prev) ,n-tail)
(setf (vop-refs ,n-vop) ,n-tail)))))
(unless (eq first-seen :yes)
(setq first-seen (if more-p :maybe :yes)))
(if more-p
(let ((n-current (gensym))
(n-prev (gensym))
(n-head (gensym)))
(binds `(,n-head (or ,var ,prev)))
(binds
`(,n-tail
(do ((,n-current ,var (tn-ref-across ,n-current))
(,n-prev nil ,n-current))
((null ,n-current) ,n-prev)
(setf (tn-ref-next-ref ,n-current) ,n-prev))))
(setq prev n-head))
(setq prev var)))))
`((let* ,(binds)
,@(forms)))))
;;; Make-Temporary -- Internal
;;;
;;; Return a form that creates a TN as specified by Temp. This requires
;;; deciding whether the temp is wired, restricted or normal.
;;;
(defun make-temporary (temp)
(declare (type operand-parse temp))
(let ((type (operand-parse-type temp)))
(cond ((operand-parse-sc temp)
`(make-wired-tn (primitive-type-or-lose ',type)
,(sc-number-or-lose (operand-parse-sc temp))
,(operand-parse-offset temp)))
((operand-parse-scs temp)
`(make-restricted-tn (primitive-type-or-lose ',type)
',(mapcar #'sc-number-or-lose
(operand-parse-scs temp))))
(t
`(make-normal-tn (primitive-type-or-lose ',type))))))
;;; Allocate-Temporaries -- Internal
;;;
;;; Allocate VOP temporary TNs, making TN-Refs for their start and end, and
;;; setting up various per-ref information. N-Vop is the temporary holding the
;;; VOP we are emitting. We return a list of let* binding forms that create
;;; the TN-Refs, a list of forms that initialize the TN-Refs.
;;;
(defun allocate-temporaries (parse n-vop)
(declare (type vop-parse parse))
(collect ((binds)
(forms))
(let ((prev-write nil))
(dolist (temp (vop-parse-temps parse))
(let ((n-write (operand-parse-temp temp))
(n-read (operand-parse-temp-temp temp))
(n-tn (gensym)))
(binds `(,n-tn ,(make-temporary temp)))
(binds `(,n-write (reference-tn ,n-tn t)))
(binds `(,n-read (reference-tn ,n-tn nil)))
(if prev-write
(forms `(setf (tn-ref-across ,prev-write) ,n-write))
(forms `(setf (vop-temps ,n-vop) ,n-write)))
(setq prev-write n-write)
(forms `(setf (tn-ref-vop ,n-read) ,n-vop))
(forms `(setf (tn-ref-vop ,n-write) ,n-vop)))))
(values (binds) (forms))))
;;; Set-VOP-Pointers -- Internal
;;;
;;; Return code to set the TN-Ref-Vop slots in some operands to the value of
;;; N-Vop. If there is no more operand, set the set the slots individually,
;;; otherwise loop over the whole list N-Refs.
;;;
(defun set-vop-pointers (operands more-operand n-vop n-refs)
(if more-operand
`((do ((,n-refs ,n-refs (tn-ref-across ,n-refs)))
((null ,n-refs))
(setf (tn-ref-vop ,n-refs) ,n-vop)))
(mapcar #'(lambda (op)
`(setf (tn-ref-vop ,(operand-parse-temp op)) ,n-vop))
operands)))
;;; Make-Emit-Function -- Internal
;;;
;;; Make the Template Emit-Function for a VOP.
;;;
(defun make-emit-function (parse)
(declare (type vop-parse parse))
(let ((n-node (gensym)) (n-block (gensym))
(n-template (gensym)) (n-args (gensym))
(n-results (gensym)) (n-info (gensym))
(n-vop (gensym))
(info-args (vop-parse-info-args parse)))
(multiple-value-bind (temp-binds temp-forms)
(allocate-temporaries parse n-vop)
`#'(lambda (,n-node ,n-block ,n-template ,n-args ,n-results
,@(when info-args `(,n-info)))
(let ((,n-vop (make-vop ,n-block ,n-node ,n-template
,n-args ,n-results)))
,@(when info-args
`((setf (vop-codegen-info ,n-vop) ,n-info)))
(let* (,@(access-operands (vop-parse-args parse)
(vop-parse-more-args parse)
n-args)
,@(access-operands (vop-parse-results parse)
(vop-parse-more-results parse)
n-results)
,@temp-binds)
,@temp-forms
,@(set-vop-pointers (vop-parse-args parse)
(vop-parse-more-args parse)
n-vop n-args)
,@(set-vop-pointers (vop-parse-results parse)
(vop-parse-more-results parse)
n-vop n-results)
,@(make-next-ref-linkage parse n-vop))
(values ,n-vop ,n-vop))))))
;;; Make-Target-Function -- Internal
;;;
;;; Make lambda that does operand targeting as indicated by the
;;; Operand-Parse-Target slots. We do some meta-compile-time consistency
;;; checking, and the emit a call to Target-If-Desirable for each operand
;;; with a target specified.
;;;
;;; If we are targeting from a temporary, then we indirect through the TN to
;;; find the read ref. This exploits the fact that a temp has exactly one
;;; read.
;;;
(defun make-target-function (parse)
(collect ((forms))
(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))))
(forms `(target-if-desirable
,(ecase (operand-parse-kind op)
(:temporary
`(tn-reads (tn-ref-tn ,(operand-parse-temp op))))
(:argument
(operand-parse-temp op)))
,(operand-parse-temp target))))))
(let ((n-vop (gensym)))
`#'(lambda (,n-vop)
(let* (,@(access-operands (vop-parse-args parse) nil
`(vop-args ,n-vop))
,@(access-operands (vop-parse-results parse) nil
`(vop-results ,n-vop))
,@(access-operands (vop-parse-temps parse) nil
`(vop-temps ,n-vop)))
,(ignore-unreferenced-temps (vop-parse-args parse))
,(ignore-unreferenced-temps (vop-parse-results parse))
,(ignore-unreferenced-temps (vop-parse-temps parse))
,@(forms))))))
;;; Make-Generator-Function -- Internal
;;;
;;; 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 (gensym)) (n-info (gensym)) (n-variant (gensym))
(operands (vop-parse-operands parse)))
(collect ((binds))
(dolist (op operands)
(ecase (operand-parse-kind op)
((:argument :result :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)))
(assemble (vop-node ,n-vop)
,@(vop-parse-body parse)))))))
;;; Parse-Operands -- Internal
;;;
;;; 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.
;;;
(defun parse-operands (specs kind)
(declare (list specs)
(type (member :argument :result) kind))
(let ((num -1)
(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 "More operand isn't last: ~S." specs))
(let ((res (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
(check-type value list)
(setf (operand-parse-scs res) value))
(:load
(check-type value boolean)
(setf (operand-parse-load res) value))
(:more
(check-type value boolean)
(setf (operand-parse-kind res)
(if (eq kind :argument) :more-argument :more-result))
(setq more res))
(:target
(check-type value symbol)
(setf (operand-parse-target res) value))
(t
(error "Unknown keyword in operand specifier: ~S." spec)))))
(unless more
(operands res))))
(values (the list (operands)) more))))
;;; Parse-Temporary -- Internal
;;;
;;; Parse a temporary specification, entering the Operand-Parse structures in
;;; the Parse structure.
;;;
(defun parse-temporary (spec parse)
(declare (list spec)
(type vop-parse parse))
(let ((len (length spec)))
(unless (>= len 2)
(error "Malformed temporary spec: ~S." spec))
(dolist (name (cddr spec))
(unless (symbolp name)
(error "Bad temporary name: ~S." name))
(let ((res (make-operand-parse :name name :kind :temporary
:temp-temp (gensym)
:born (parse-time-spec :load)
:dies (parse-time-spec :save))))
(unless (evenp (length (second spec)))
(error "Odd number of argument in keyword options: ~S." spec))
(do ((opt (second spec) (cddr opt)))
((null opt))
(case (first opt)
(:target
(setf (operand-parse-target res)
(vop-spec-arg opt 'symbol 1 nil)))
(:type
(setf (operand-parse-type res)
(vop-spec-arg opt 'symbol 1 nil)))
(:scs
(setf (operand-parse-scs res)
(vop-spec-arg opt 'list 1 nil)))
(:sc
(setf (operand-parse-sc res)
(vop-spec-arg opt 'symbol 1 nil)))
(:offset
(let ((offset (eval (second opt))))
(check-type 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))))
(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))
(when (if (operand-parse-sc res)
(not (operand-parse-offset res))
(operand-parse-offset res))
(error "Must specify both :SC and :Offset or neither: ~S." spec))
(when (and (operand-parse-sc res)
(operand-parse-scs res))
(error "Cannot specify both :SC and :SCs: ~S." spec))
(setf (vop-parse-temps parse)
(cons res
(remove name (vop-parse-temps parse)
:key #'operand-parse-name))))))
(undefined-value))
;;; Parse-Define-VOP -- Internal
;;;
;;; 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-operands (rest spec) :argument)
(setf (vop-parse-args parse) fixed)
(setf (vop-parse-more-args parse) more)))
(:results
(multiple-value-bind
(fixed more)
(parse-operands (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)))
(:node-var
(setf (vop-parse-node-var parse) (vop-spec-arg spec 'symbol)))
(:note
(setf (vop-parse-note parse) (vop-spec-arg spec 'string)))
(:arg-types
(setf (vop-parse-arg-types parse) (rest spec)))
(:result-types
(setf (vop-parse-result-types parse) (rest spec)))
(:translate
(setf (vop-parse-translate parse) (rest spec)))
(:guard
(setf (vop-parse-guard parse) (vop-spec-arg spec t)))
(:policy
(setf (vop-parse-policy parse) (vop-spec-arg spec 'policies)))
(:save-p
(setf (vop-parse-save-p parse)
(vop-spec-arg spec '(member t nil :force-to-stack))))
(t
(error "Unknown option specifier: ~S." (first spec)))))
(undefined-value))
;;;; Make costs and restrictions:
(defconstant no-restriction
(make-array sc-number-limit :element-type 'bit :initial-element 1))
(defconstant no-costs
(make-array sc-number-limit :initial-element 0))
;;; Compute-Loading-Costs -- Internal
;;;
;;; Given a operand, return a costs vector with costs filled in for all SCs
;;; that we could load from. When there are multiple SCs we can load into, we
;;; use the one with the lowest aggregate cost. Load-P specifies the
;;; direction: if true, we are loading, if false we are saving.
;;;
(defun compute-loading-costs (op load-p)
(declare (type operand-parse op))
(let ((scs (operand-parse-scs op)))
(if scs
(let ((res (make-array sc-number-limit :initial-element nil)))
(dolist (sc-name scs)
(let ((load-sc (sc-number-or-lose sc-name)))
(setf (svref res load-sc) 0)
(dotimes (op-sc sc-number-limit)
(let ((load (if load-p
(aref *move-costs* op-sc load-sc)
(aref *move-costs* load-sc op-sc))))
(when load
(let ((op-cost (svref res op-sc)))
(when (or (not op-cost) (< load op-cost))
(setf (svref res op-sc) load))))))))
res)
no-costs)))
;;; Compute-SC-Restrictions -- Internal
;;;
;;; Return the SC restriction bit-vector for Op. If there are no
;;; restrictions, or Load false, then return No-Restriction.
;;;
(defun compute-sc-restrictions (op)
(declare (type operand-parse op))
(let ((scs (operand-parse-scs op)))
(if (and scs (operand-parse-load op))
(let ((restr (make-array sc-number-limit :element-type 'bit
:initial-element 0)))
(dolist (name scs)
(setf (sbit restr (sc-number-or-lose name)) 1))
restr)
no-restriction)))
;;; Make-Costs-And-Restrictions -- Internal
;;;
(defun make-costs-and-restrictions (parse)
`(
:cost ,(vop-parse-cost parse)
:arg-costs
',(mapcar #'(lambda (x)
(compute-loading-costs x t))
(vop-parse-args parse))
:result-costs
',(mapcar #'(lambda (x)
(compute-loading-costs x nil))
(vop-parse-results parse))
:more-arg-costs
',(if (vop-parse-more-args parse)
(compute-loading-costs (vop-parse-more-args parse) t)
nil)
:more-result-costs
',(if (vop-parse-more-results parse)
(compute-loading-costs (vop-parse-more-results parse) nil)
nil)
:arg-restrictions
',(mapcar #'compute-sc-restrictions (vop-parse-args parse))
:result-restrictions
',(mapcar #'compute-sc-restrictions (vop-parse-results parse))))
;;;; Operand checking and stuff:
;;; Check-Operand-Types -- Internal
;;;
;;; If the operand types are specified, then check the number specified
;;; against the number of defined operands.
;;;
;;; [### This would be a good place to check if the operand type is consistent
;;; with the SC restriction.]
;;;
(defun check-operand-types (ops more-op types what)
(declare (list ops) (type (or list (member :unspecified)) types)
(type (or operand-parse null) more-op) (string what))
(let ((num (+ (length ops) (if more-op 1 0))))
(unless (or (eq types :unspecified) (= (length types) num))
(error "Expected ~D ~A type~P: ~S." num what types num)))
(undefined-value))
;;; Grovel-Operands -- Internal
;;;
;;; Compute stuff that can only be computed after we are done parsing
;;; everying. We set the VOP-Parse-Operands, and do various error checks.
;;;
(defun grovel-operands (parse)
(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)))
(check-operand-types (vop-parse-args parse)
(vop-parse-more-args parse)
(vop-parse-arg-types parse)
"argument")
(check-operand-types (vop-parse-results parse)
(vop-parse-more-results parse)
(vop-parse-result-types parse)
"result")
(undefined-value))
;;;; Function translation stuff:
;;; Adjoin-Template -- Internal
;;;
;;; Add Template into Info's Templates, removing any old template with the
;;; same name.
;;;
(defun adjoin-template (info template)
(declare (type function-info info) (type template template))
(setf (function-info-templates info)
(sort (cons template
(remove (template-name template)
(function-info-templates info)
:key #'template-name))
#'<=
:key #'template-cost))
(undefined-value))
;;; Set-Up-Function-Translation -- Internal
;;;
;;; Return forms to establish this VOP as a IR2 translation template for the
;;; :Translate functions specified in the VOP-Parse. We also set the
;;; Predicate attribute for each translated function when the VOP is
;;; conditional, causing IR1 conversion to ensure that a call to the translated
;;; is always used in a predicate position.
;;;
(defun set-up-function-translation (parse n-template)
(declare (type vop-parse parse))
(mapcar #'(lambda (name)
`(let ((info (function-info-or-lose ',name)))
(adjoin-template info ,n-template)
,@(when (vop-parse-conditional-p parse)
'((setf (function-info-attributes info)
(attributes-union
(ir1-attributes predicate)
(function-info-attributes info)))))))
(vop-parse-translate parse)))
;;; Make-Operand-Type -- Internal
;;;
(defun make-operand-type (type)
(if (eq type '*)
''*
`(primitive-type-or-lose ',type)))
;;; Specify-Operand-Types -- Internal
;;;
(defun specify-operand-types (types ops more-ops)
(if (eq types :unspecified)
(make-list (+ (length ops) (if more-ops 1 0)) :initial-element t)
types))
;;; Make-VOP-Info-Types -- Internal
;;;
;;; Return a list of forms to use as keyword args to Make-VOP-Info for
;;; setting up the template argument and result types. Here we make an initial
;;; dummy Template-Type, since it is awkward to compute the type until the
;;; template has been made.
;;;
(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)))
`(
: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)))
:more-results-type ,(when more-results
(make-operand-type more-result)))))
;;;; Set up VOP-Info:
(defconstant slot-inherit-alist
'((:emit-function . vop-info-emit-function)
(:generator-function . vop-info-generator-function)
(:target-function . vop-info-target-function)))
;;; Inherit-VOP-Info -- Internal
;;;
;;; Something to help with inheriting VOP-Info slots. We return a
;;; keyword/value pair that can be passed to the constructor. Slot is the
;;; keyword name of the slot, Parse is a form that evaluates to the VOP-Parse
;;; structure for the VOP inherited. If Parse is NIL, then we do nothing. If
;;; the Test form evaluates to true, then we return a form that selects the
;;; named slot from the VOP-Info structure corresponding to Parse. Otherwise,
;;; we return the Form so that the slot is recomputed.
;;;
(defmacro inherit-vop-info (slot parse test form)
`(if (and iparse ,test)
(list ,slot `(,',(or (cdr (assoc slot slot-inherit-alist))
(error "Unknown slot ~S." slot))
(template-or-lose ',(vop-parse-name ,parse))))
(list ,slot ,form)))
;;; Set-Up-VOP-Info -- Internal
;;;
;;; 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)))
(let ((nvars (length (vop-parse-variant-vars parse))))
(unless (= (length variant) nvars)
(error "Expected ~D 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)))
:note ',(vop-parse-note parse)
:info-arg-count ,(length (vop-parse-info-args parse))
:policy ',(vop-parse-policy parse)
:save-p ',(vop-parse-save-p parse)
:effects (vop-attributes ,@(vop-parse-effects parse))
:affected (vop-attributes ,@(vop-parse-affected parse))
,@(make-costs-and-restrictions parse)
,@(inherit-vop-info :emit-function iparse
same-operands
(make-emit-function 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)))
,@(inherit-vop-info :target-function iparse
same-operands
(when (some #'operand-parse-target (vop-parse-operands parse))
(make-target-function parse)))
:variant (list ,@variant))))
); Eval-When (Compile Load Eval)
;;; Template-Type-Specifier -- Internal
;;;
;;; Return a function type specifier describing Template's type computed
;;; from the operand type restrictions.
;;;
(defun template-type-specifier (template)
(declare (type template template))
(flet ((convert (types more-types)
(flet ((frob (x)
(if (eq x '*)
't
(type-specifier (primitive-type-type x)))))
`(,@(mapcar #'frob types)
,@(when more-types
`(&rest ,(frob more-types)))))))
(let* ((args (convert (template-arg-types template)
(template-more-args-type template)))
(result-restr (template-result-types template))
(results (if (eq result-restr :conditional)
'(boolean)
(convert result-restr
(cond ((template-more-results-type template))
((/= (length result-restr) 1) '*)
(t nil))))))
`(function ,args
,(if (= (length results) 1)
(first results)
`(values ,@results))))))
;;; Define-VOP -- Public
;;;
;;; 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.
;;;
(defmacro define-vop ((name &optional inherits) &rest specs)
"Define-VOP (Name [Inherits]) Spec*
Define the symbol Name to be a Virtual OPeration in the compiler. If
specified, Inherits is the name of a VOP that we default unspecified
information from. Each Spec is a list beginning with a keyword indicating
the interpretation of the other forms in the Spec:
:Args {(Name {Key Value}*)}*
:Results {(Name {Key Value}*)}*
The Args and Results are specifications of the operand TNs passed to the
VOP. The following operand options are defined:
:SCs (SC*)
:Load T-or-NIL
:SCs specifies good SCs for this operand. Other SCs will be
penalized according to move costs. If :Load is true (the default),
then a load TN will be allocated if necessary, guaranteeing that the
operand is always one of the specified SCs.
:More T-or-NIL
If specified, Name is bound to the TN-Ref for the first argument or
result following the fixed arguments or results. A more operand must
appear last, and cannot be targeted or restricted.
:Target Operand
This operand is targeted to the named operand, indicating a desire to
pack in the same location. Not legal for results.
:Conditional
This is used in place of :Results with conditional branch VOPs. There
are no result values: the result is a transfer of control. The
consequent and alternative continuations are passed as the first and
second :Info arguments. A side-effect is to set the Predicate attribute
for functions in the :Translate option.
:Temporary ({Key Value}*) Name*
Allocate a temporary TN for each Name, binding that variable to the TN
within the body of the generators. In addition to :Target (which is
is the same as for operands), the following options are
defined:
:Type Type
Specify the primitive type for the temporary, default T.
: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.
:SCs (SC*)
Restrict the temporary to a subset of the SCs allowed by the type,
possibly requiring packing in a finite SC.
:From Time-Spec
:To Time-Spec
Specify the beginning and end of the temporary's 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. the second argument's
life ends at (:Argument 1).
:Generator Cost Form*
Specifies the translation into assembly code. Cost is the estimated cost
of the code emitted by this generator. The body is arbitrary Lisp code
that emits the assembly language translation of the VOP. An Assemble
form is wrapped around the body, so code may be emitted by using the
local Inst macro. During the evaluation of the body, the names of the
operands and temporaries are bound to the actual TNs.
:Effects Effect*
:Affected Effect*
Specifies the side effects that this VOP has and the side effects that
effect its execution. If unspecified, these default to the worst case.
:Info Name*
Define some magic arguments that are passed directly to the code
generator. The corresponding trailing arguments to VOP or %Primitive are
stored in the VOP structure. Within the body of the generators, the
named variables are bound to these values. Except in the case of
:Conditional VOPs, :Info arguments cannot be specified for VOPS that are
the direct translation for a function (specified by :Translate).
:Ignore Name*
Causes the named variables to be declared IGNORE in the generator body.
:Variant Thing*
:Variant-Vars Name*
These options provide a way to parameterize families of VOPs that differ
only trivially. :Variant makes the specified evaluated Things be the
\"variant\" associated with this VOP. :Variant-Vars causes the named
variables to be bound to the corresponding Things within the body of the
generator.
:Variant-Cost Cost
Specifies the cost of this VOP, overriding the cost of any inherited
generator.
:Note String
A short noun-like phrase describing what this VOP \"does\", i.e. the
implementation strategy. This is for use in efficiency notes.
:Arg-Types Type*
:Result-Types Type*
Specify the template type restrictions used for automatic translation.
If there is a :More operand, the last type is the more type.
:Translate Name*
This option causes the VOP template to be entered as an IR2 translation
for the named functions.
:Policy {:Small | :Fast | :Safe | :Fast-Safe}
Specifies the policy under which this VOP is the best translation.
:Guard Form
Specifies a Form that is evaluated in the global environment. If
form returns NIL, then emission of this VOP is prohibited even when
all other restrictions are met.
:Save-P {T | NIL | :Force-To-Stack}
Indicates how a VOP wants live registers saved."
(check-type name symbol)
(let* ((iparse (when inherits
(vop-parse-or-lose inherits)))
(parse (if inherits
(copy-vop-parse iparse)
(make-vop-parse)))
(n-res (gensym)))
(setf (vop-parse-name parse) name)
(setf (vop-parse-inherits parse) inherits)
(parse-define-vop parse specs)
(grovel-operands parse)
`(progn
(eval-when (compile load eval)
(setf (gethash ',name *parsed-vops*) ',parse))
(let ((,n-res ,(set-up-vop-info iparse parse)))
(setf (gethash ',name *template-names*) ,n-res)
(setf (template-type ,n-res)
(specifier-type (template-type-specifier ,n-res)))
,@(set-up-function-translation parse n-res))
',name)))
;;;; Emission macros:
(eval-when (compile load eval)
;;; Make-Operand-List -- Internal
;;;
;;; Return code to make a list of VOP arguments or results, linked by
;;; TN-Ref-Across. The first value is code, the second value is LET* forms,
;;; and the third value is a variable that evaluates to the head of the list,
;;; or NIL if there are no operands. Fixed is a list of forms that evaluate to
;;; TNs for the fixed operands. TN-Refs will be made for these operands
;;; according using the specified value of Write-P. More is an expression that
;;; evaluates to a list of TN-Refs that will be made the tail of the list. If
;;; it is constant NIL, then we don't bother to set the tail.
;;;
(defun make-operand-list (fixed more write-p)
(collect ((forms)
(binds))
(let ((n-head 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)))
(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))))
(values (forms) (binds) n-head))))
); Eval-When (Compile Load Eval)
;;; Emit-Template -- Interface
;;;
(defmacro emit-template (node block template args results &optional info)
"Emit-Template Node Block Template Args Results [Info]
Call the emit function for Template, linking the result in at the end of
Block."
(let ((n-first (gensym))
(n-last (gensym)))
(once-only ((n-node node)
(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)))))
;;; VOP -- Interface
;;;
(defmacro vop (name node block &rest operands)
"VOP Name Node Block Arg* Info* Result*
Emit the VOP (or other template) Name at the end of the IR2-Block Block,
using Node for the source context. The interpretation of the remaining
arguments depends on the number of operands of various kinds that are
declared in the template definition. VOP cannot be used for templates that
have more-args or more-results, since the number of arguments and results is
indeterminate for these templates. Use VOP* instead.
Args and Results are the TNs that are to be referenced by the template
as arguments and results. If the template has codegen-info arguments, then
the appropriate number of Info forms following the Arguments are used for
codegen info."
(let* ((parse (vop-parse-or-lose name))
(arg-count (length (vop-parse-args parse)))
(result-count (length (vop-parse-results parse)))
(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))
(multiple-value-bind
(acode abinds n-args)
(make-operand-list (subseq operands 0 arg-count) nil nil)
(multiple-value-bind
(rcode rbinds n-results)
(make-operand-list (subseq operands (+ arg-count info-count)) nil t)
(collect ((ibinds)
(ivars))
(dolist (info (subseq operands arg-count (+ arg-count info-count)))
(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)))))
(undefined-value)))))))
;;; VOP* -- Interface
;;;
(defmacro vop* (name node block args results &rest info)
"VOP* Name Node Block (Arg* More-Args) (Result* More-Results) Info*
Like VOP, but allows for emission of templates with arbitrary numbers of
arguments, and for emission of templates using already-created TN-Ref lists.
The Arguments and Results are TNs to be referenced as the first arguments
and results to the template. More-Args and More-Results are heads of TN-Ref
lists that are added onto the end of the TN-Refs for the explicitly supplied
operand TNs. The TN-Refs for the more operands must have the TN and Write-P
slots correctly initialized.
As with VOP, the Info forms are evaluated and passed as codegen info
arguments."
(check-type args cons)
(check-type results cons)
(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)))
(unless (or (vop-parse-more-args parse)
(<= (length fixed-args) arg-count))
(error "Too many fixed arguments."))
(unless (or (vop-parse-more-results parse)
(<= (length fixed-results) result-count))
(error "Too many fixed results."))
(unless (= (length info) info-count)
(error "Expected ~D info args." info-count))
(multiple-value-bind
(acode abinds n-args)
(make-operand-list fixed-args (car (last args)) nil)
(multiple-value-bind
(rcode rbinds n-results)
(make-operand-list fixed-results (car (last results)) t)
`(let* ((,n-node ,node)
(,n-block ,block)
(,n-template (template-or-lose ',name))
,@abinds
,@rbinds)
,@acode
,@rcode
(emit-template ,n-node ,n-block ,n-template ,n-args ,n-results
,@(when info
`((list ,@info))))
(undefined-value))))))
;;;; Random macros:
;;; SC-Case -- Public
;;;
(defmacro sc-case (tn &rest forms)
"SC-Case TN {({(SC-Name*) | SC-Name | T} Form*)}*
Case off of TN's SC. The first clause containing TN's SC is evaulated,
returning the values of the last form. A clause beginning with T specifies a
default. If it appears, it must be last. If no default is specified, and no
clause matches, then an error is signalled."
(let ((n-sc (gensym))
(n-tn (gensym)))
(collect ((clauses))
(do ((cases forms (rest cases)))
((null cases)
(clauses `(t (error "Unknown SC to SC-Case for ~S." ,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 ,(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))))))
;;; SC-Is -- Interface
;;;
(defmacro sc-is (tn &rest scs)
"SC-Is TN SC*
Returns true if TNs SC is any of the named SCs, false otherwise."
(once-only ((n-sc `(sc-number (tn-sc ,tn))))
`(or ,@(mapcar #'(lambda (x)
`(eql ,n-sc ,(sc-number-or-lose x)))
scs))))
;;; Do-IR2-Blocks -- Interface
;;;
(defmacro do-ir2-blocks ((block-var component &optional result)
&body forms)
"Do-IR2-Blocks (Block-Var Component [Result]) Form*
Iterate over the IR2 blocks in component, in emission order."
`(do ((,block-var (block-info (component-head ,component))
(ir2-block-next ,block-var)))
((null ,block-var) ,result)
,@forms)))
;;;; Utilities for defining miscops:
(eval-when (compile load eval)
;;; Miscop-Name -- Internal
;;;
;;; Return the name for a miscop with the specified args/results.
;;;
(defun miscop-name (nargs nresults conditional)
(intern (if conditional
(format nil "~:@(~R-ARG-CONDITIONAL-MISCOP~)"
nargs)
(format nil "~:@(~R-ARG~[-NO-VALUE~;~:;-~:*~R-VALUE~]-MISCOP~)"
nargs nresults))
(find-package "C")))
); Eval-When (Compile Load Eval)
;;; Define-Miscop-Variants -- Interface
;;;
;;; Define a bunch of miscops VOPs that inherit the specified VOP and whose
;;; Template name, Miscop name and translate function are all the same.
;;;
;;; ### We intern the Variant name in the COMPILER package to get around
;;; bootstrapping package lossage.
;;;
(defmacro define-miscop-variants (vop &rest names)
(collect ((res))
(dolist (name names)
(res `(define-vop (,name ,vop)
(:translate ,name)
(:variant ',(intern (symbol-name name)
(find-package "COMPILER"))))))
`(progn ,@(res))))
;;; Define-Miscop -- Interface
;;;
;;; Define a miscop with the specified args/results and options.
;;;
(defmacro define-miscop (name args &key (results '(r)) translate
policy arg-types result-types
cost conditional)
`(define-vop (,name ,(miscop-name (length args) (length results)
conditional))
(:variant ',(intern (symbol-name name)
(find-package "COMPILER")))
,@(when arg-types
`((:arg-types ,@arg-types)))
,@(when result-types
`((:result-types ,@result-types)))
,@(when policy
`((:policy ,policy)))
,@(when cost
`((:variant-cost ,cost)))
,@(when translate
`((:translate ,translate)))))