;;; 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))
- (ctype-form `(specifier-type ',type)))
+ (let ((scns (mapcar #'meta-sc-number-or-lose scs)))
`(progn
(/show0 "doing !DEF-PRIMITIVE-TYPE, NAME=..")
(/primitive-print ,(symbol-name name))
(setf (gethash ',name *backend-meta-primitive-type-names*)
(make-primitive-type :name ',name
:scs ',scns
- :type ,ctype-form)))
- ,(once-only ((n-old `(gethash ',name *backend-primitive-type-names*))
- (n-type ctype-form))
+ :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
(cond (,n-old
(/show0 "in ,N-OLD clause of COND")
(setf (primitive-type-scs ,n-old) ',scns)
- (setf (primitive-type-type ,n-old) ,n-type))
+ (setf (primitive-type-specifier ,n-old) ',type))
(t
(/show0 "in T clause of COND")
(setf (gethash ',name *backend-primitive-type-names*)
(make-primitive-type :name ',name
:scs ',scns
- :type ,n-type))))
+ :specifier ',type))))
(/show0 "done with !DEF-PRIMITIVE-TYPE")
',name)))))
(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)
;; 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
;;; 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))
;;; 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)))))
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
+ ;; :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)))
(rassoc name (funs)))))
(unless name
(error "no move function defined to ~:[save~;load~] SC ~S ~
- with ~S ~:[to~;from~] from 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~]~@
- or ~S when operand is in SC ~S"
+ with ~S or ~S when operand is in SC ~S"
load-p name (cdr found) (sc-name alt)))
(pushnew alt (car found)))
(t
(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))))
+ (setf (vop-parse-vop-var parse) '.vop.)))
(form (if (rest funs)
`(sc-case ,tn
,@(mapcar (lambda (x)
,@(vop-parse-body parse))
,@(saves))))))
\f
+(defvar *parse-vop-operand-count*)
+(defun make-operand-parse-temp ()
+ ;; FIXME: potentially causes breakage in contribs from locked
+ ;; packages.
+ (intern (format nil "OPERAND-PARSE-TEMP-~D" *parse-vop-operand-count*)
+ (symbol-package '*parse-vop-operand-count*)))
+(defun make-operand-parse-load-tn ()
+ (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.
(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
(dolist (name (cddr spec))
(unless (symbolp 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)))
:key #'operand-parse-name))))))
(values))
\f
+(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) 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
(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.
;;;
;;; 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