(/show0 "doing third SETF")
(setf (finite-sb-live-tns res)
(make-array ',size :initial-element nil))
- (/show0 "doing fourth and final SETF")
+ (/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)))
(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
((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"
+ mentioned in the restriction for operand ~S"
sc-name load-p (operand-parse-name op))))))
(funs)))
(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)
,form)))
`(when ,load-tn
(error "load TN allocated, but no move function?~@
- VM definition is inconsistent, recompile and try again.")))))
+ 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
,@(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
(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"
+ ~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)))
(let ((alias (parse-operand-type alias)))
(unless (eq (car alias) :or)
(error "can't include primitive-type ~
- alias ~S in an :OR restriction: ~S"
+ alias ~S in an :OR restriction: ~S"
item spec))
(dolist (x (cdr alias))
(results x)))
(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.
;;;
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.]~]"
+ 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 '*)))))
(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"
+ 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)))))
projects / sbcl.git / blobdiff