diff --git a/compiler/vmdef.lisp b/compiler/vmdef.lisp index af9a0c0b74a036db13c0279b644030d43f179f6a..c488949dd6f8f7d65c38da6c0b6ff3e98aea38b2 100644 --- a/compiler/vmdef.lisp +++ b/compiler/vmdef.lisp @@ -130,24 +130,43 @@ ;;; ;;; (defmacro define-storage-class (name number sb-name &key (element-size '1) - locations) + locations save-p alternate-scs + constant-scs) "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> + :Element-Size Size The size of objects in this SC in whatever units the SB uses. This defaults to 1. - :Locations + :Locations (Location*) If the SB is :Finite, then this is a list of the offsets within the SB - that are in this SC." + that are in this SC. + + :Save-P {T | NIL} + If T, then values stored in this SC must be saved in one of the + non-save-p :Alternate-SCs across calls. + + :Alternate-SCs (SC*) + Indicates other SCs that can be used to hold values from this SC across + calls or when storage in this SC is exhausted. The SCs should be + specified in order of decreasing \"goodness\". Unless this SC is only + used for restricted or wired TNs, then there must be a last SC in an + unbounded SB. + + :Constant-SCs (SC*) + A list of the names of all the constant SCs that can be loaded into this + SC by a load function." (check-type name symbol) (check-type number sc-number) (check-type sb-name symbol) (check-type locations list) + (check-type save-p boolean) + (check-type alternate-scs list) + (check-type constant-scs list) (let ((sb (sb-or-lose sb-name))) (if (eq (sb-kind sb) :finite) @@ -159,27 +178,150 @@ (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))) + (error ":Locations is meaningless in a ~S SB." (sb-kind sb)))) + + (when (and (or alternate-scs constant-scs) + (eq (sb-kind sb) :non-packed)) + (error "Meaningless to specify alternate or constant SCs in a ~S SB." + (sb-kind sb)))) + + (let ((nstack-p + (if (or (eq sb-name 'number-stack) + (find 'number-stack (mapcar #'sc-or-lose alternate-scs) + :key #'(lambda (x) + (sb-name (sc-sb x))))) + t nil))) + `(progn + (eval-when (compile load eval) + (let ((res (make-sc :name ',name :number ',number + :sb (sb-or-lose ',sb-name) + :element-size ,element-size + :locations ',locations + :save-p ',save-p + :number-stack-p ,nstack-p + :alternate-scs (mapcar #'sc-or-lose + ',alternate-scs) + :constant-scs (mapcar #'sc-or-lose + ',constant-scs)))) + (setf (gethash ',name *sc-names*) res) + (setf (svref *meta-sc-numbers* ',number) res) + (setf (svref (sc-load-costs res) ',number) 0))) + + (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))) - (eval-when (compile eval) - (setf (svref *meta-sc-numbers* ',number) - (gethash ',name *sc-names*))) + +;;;; Move/coerce definition: - (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)) +;;; DO-SC-PAIRS -- Internal +;;; +;;; Given a list of paris of lists of SCs (as given to DEFINE-MOVE-VOP, +;;; etc.), bind TO-SC and FROM-SC to all the combinations. +;;; +(eval-when (compile load eval) + (defmacro do-sc-pairs ((from-sc-var to-sc-var scs) &body body) + `(do ((froms ,scs (cddr froms)) + (tos (cdr ,scs) (cddr tos))) + ((null froms)) + (dolist (from (car froms)) + (let ((,from-sc-var (sc-or-lose from))) + (dolist (to (car tos)) + (let ((,to-sc-var (sc-or-lose to))) + ,@body))))))) + + +;;; DEFINE-MOVE-FUNCTION -- Public +;;; +(defmacro define-move-function ((name cost) lambda-list scs &body body) + "Define-Move-Function (Name Cost) lambda-list ({(From-SC*) (To-SC*)}*) form* + Define the function Name and note it as the function used for moving operands + from the From-SCs to the To-SCs. Cost is the cost of this move operation. + The function is called with three arguments: the node (for source context), + and the source and destination TNs. An ASSEMBLE form is wrapped around the + body. All uses of DEFINE-MOVE-FUNCTION should be compiled before any uses of + DEFINE-VOP." + (when (or (oddp (length scs)) (null scs)) + (error "Malformed SCs spec: ~S." scs)) + (check-type cost index) + `(progn + (eval-when (compile load eval) + (do-sc-pairs (from-sc to-sc ',scs) + (unless (eq from-sc to-sc) + (let ((num (sc-number from-sc))) + (setf (svref (sc-load-functions to-sc) num) ',name) + (setf (svref (sc-load-costs to-sc) num) ',cost))))) + + (defun ,name ,lambda-list + (assemble ,(first lambda-list) ,@body)))) + + +(defconstant sc-vop-slots '((:move . sc-move-vops) + (:move-argument . sc-move-arg-vops))) + + +;;; COMPUTE-MOVE-COSTS -- Internal +;;; +;;; Compute at meta-compile time the costs for moving between all SCs that +;;; can be loaded from FROM-SC and to TO-SC given a base move cost Cost. +;;; +(defun compute-move-costs (from-sc to-sc cost) + (declare (type sc from-sc to-sc) (type index cost)) + (let ((to-scn (sc-number to-sc)) + (from-costs (sc-load-costs from-sc))) + (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc))) + (let ((vec (sc-move-costs dest-sc)) + (dest-costs (sc-load-costs dest-sc))) + (setf (svref vec (sc-number from-sc)) cost) + (dolist (sc (append (sc-alternate-scs from-sc) + (sc-constant-scs from-sc))) + (let* ((scn (sc-number sc)) + (total (+ (svref from-costs scn) + (svref dest-costs to-scn) + cost)) + (old (svref vec scn))) + (unless (and old (< old total)) + (setf (svref vec scn) total)))))))) + + +;;; DEFINE-MOVE-VOP -- Public +;;; +;;; Note that we record the VOP in the Move[-Argument]-VOPS for all SCs that +;;; we can move between (including implicit loading), whereas we only record +;;; MOVE-COSTS for the explicitly specified SC pairs. +;;; +(defmacro define-move-vop (name kind &rest scs) + "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)))) + `(progn + ,@(when (eq kind :move) + `((eval-when (compile load eval) + (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))) + (setf (svref vec (sc-number from-sc)) vop) + (dolist (sc (append (sc-alternate-scs from-sc) + (sc-constant-scs from-sc))) + (let ((scn (sc-number sc))) + (unless (svref vec scn) + (setf (svref vec scn) vop))))))))))) ;;;; Primitive type definition: @@ -245,35 +387,9 @@ (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)))) + '((:check . primitive-type-check)))) ;;; Primitive-Type-Vop -- Public @@ -283,12 +399,6 @@ 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." @@ -308,108 +418,6 @@ 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: ;;; @@ -497,7 +505,12 @@ (policy :fast :type policies) ;; ;; Stuff used by life analysis. - (save-p nil :type (member t nil :compute-only :force-to-stack))) + (save-p nil :type (member t nil :compute-only :force-to-stack)) + ;; + ;; Info about how to emit move-argument VOPs for the more operand in + ;; call/return VOPs. + (move-args nil :type (member nil :local-call :full-call :known-return))) + (defprinter vop-parse name @@ -520,8 +533,9 @@ effects affected translate - policy) - + policy + (save-p :test save-p) + (move-args :test move-args)) ;;; The Operand-Parse structure contains stuff we need to know about and ;;; operand or temporary at meta-compile time. Besides the obvious stuff, we @@ -555,27 +569,30 @@ ;; 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) + ;; 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) ;; - ;; The primitive-type of a temporary. - (type t :type symbol) + ;; If true, automatic operand loading is inhibited and the operand name is + ;; always bound to the original TN. + (load t :type boolean) ;; - ;; In a wired temporary this is the SC and offset it is wired to. + ;; In a wired or restricted temporary this is the SC the TN is to be packed + ;; in. Null otherwise. (sc nil :type (or symbol null)) + ;; + ;; If non-null, we are a temp wired to this offset in SC. (offset nil :type (or unsigned-byte null))) (defprinter operand-parse name kind - (type :test (not (eq type t))) (target :test target) born dies (scs :test scs) - load + (load :test load) (sc :test sc) (offset :test offset)) @@ -803,21 +820,16 @@ ;;; 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. +;;; deciding whether the temp is wired or restricted. ;;; (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)))))) + (let ((sc (operand-parse-sc temp)) + (offset (operand-parse-offset temp))) + (assert sc) + (if offset + `(make-wired-tn ,(sc-number-or-lose sc) ,offset) + `(make-restricted-tn ,(sc-number-or-lose sc))))) ;;; Allocate-Temporaries -- Internal @@ -946,6 +958,121 @@ ,@(forms)))))) +;;;; Generator functions: + +;;; FIND-LOAD-FUNCTIONS -- Internal +;;; +;;; Return an alist that translates from lists of SCs we can load OP from to +;;; the load function used for loading those SCs. We quietly ignore +;;; restrictions to :non-packed (constant) SCs, since we don't load into those +;;; SCs. +;;; +(defun find-load-functions (op load-p) + (collect ((funs)) + (dolist (sc-name (operand-parse-scs op)) + (let* ((sc (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) + (let* ((altn (sc-number alt)) + (name (if load-p + (svref (sc-load-functions sc) altn) + (svref (sc-load-functions alt) scn))) + (found (or (assoc alt (funs) :test #'member) + (rassoc name (funs))))) + (unless name + (error "No load 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))))))) + ((eq (sb-kind (sc-sb sc)) :non-packed)) + (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))) + + +;;; CALL-LOAD-FUNCTION -- Internal +;;; +;;; Return a form to load/save the specified operand when it has a load TN. +;;; For any given SC that we can load from, there must be a unique load +;;; function. If all SCs we can load from have the same load function, then we +;;; just call that when there is a load TN. If there are multiple possible +;;; load functions, then we dispatch off of the operand TN's type to see which +;;; load function to use. +;;; +(defun call-load-function (parse op load-p) + (let ((funs (find-load-functions op load-p)) + (load-tn (operand-parse-load-tn op))) + (if funs + (let* ((tn `(tn-ref-tn ,(operand-parse-temp op))) + (n-node (or (vop-parse-node-var parse) + (setf (vop-parse-node-var parse) (gensym)))) + (form (if (rest funs) + `(sc-case ,tn + ,@(mapcar #'(lambda (x) + `(,(mapcar #'sc-name (car x)) + ,(if load-p + `(,(cdr x) ,n-node ,tn + ,load-tn) + `(,(cdr x) ,n-node ,load-tn + ,tn)))) + funs)) + (if load-p + `(,(cdr (first funs)) ,n-node ,tn ,load-tn) + `(,(cdr (first funs)) ,n-node ,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 load function?~@ + VM definition inconsistent, recompile and try again."))))) + + +;;; DECIDE-TO-LOAD -- Internal +;;; +;;; 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))) + (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) + #+new-compiler + (declare (ignorable ,@(ignores))) + #-new-compiler + (progn ,@(ignores)) + ,load)) + ,load-tn + (tn-ref-tn ,temp)))))) + + ;;; Make-Generator-Function -- Internal ;;; ;;; Make a lambda that parses the VOP TN-Refs, does automatic operand @@ -956,10 +1083,23 @@ (let ((n-vop (vop-parse-vop-var parse)) (operands (vop-parse-operands parse)) (n-info (gensym)) (n-variant (gensym))) - (collect ((binds)) + (collect ((binds) + (loads) + (saves)) (dolist (op operands) (ecase (operand-parse-kind op) - ((:argument :result :temporary) + ((:argument :result) + (let ((temp (operand-parse-temp op)) + (name (operand-parse-name op))) + (binds `(,(operand-parse-load-tn op) (tn-ref-load-tn ,temp))) + (cond ((and (operand-parse-load op) (operand-parse-scs op)) + (binds `(,name ,(decide-to-load parse op))) + (if (eq (operand-parse-kind op) :argument) + (loads (call-load-function parse op t)) + (saves (call-load-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)))) @@ -985,8 +1125,10 @@ `((,(vop-parse-node-var parse) (vop-node ,n-vop)))) ,@(binds)) (declare (ignore ,@(vop-parse-ignores parse))) + ,@(loads) (assemble (vop-node ,n-vop) - ,@(vop-parse-body parse))))))) + ,@(vop-parse-body parse)) + ,@(saves)))))) ;;; Parse-Operands -- Internal @@ -1023,22 +1165,38 @@ (case (first key) (:scs (check-type value list) - (setf (operand-parse-scs res) value)) - (:load - (check-type value boolean) + (setf (operand-parse-scs res) (remove-duplicates value))) + (:load-tn + (check-type value symbol) + (setf (operand-parse-load-tn res) value)) + (:load-if (setf (operand-parse-load res) value)) (:more (check-type value boolean) (setf (operand-parse-kind res) (if (eq kind :argument) :more-argument :more-result)) + (setf (operand-parse-load res) nil) (setq more res)) (:target (check-type value symbol) (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))))) - (unless more - (operands res)))) + + (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)))) @@ -1068,12 +1226,6 @@ (: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))) @@ -1085,6 +1237,14 @@ (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)))) @@ -1094,14 +1254,8 @@ (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)) + (unless (operand-parse-sc res) + (error "Must specifiy :SC for all temporaries: ~S" spec)) (setf (vop-parse-temps parse) (cons res @@ -1164,14 +1318,20 @@ (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 'string))) + (setf (vop-parse-note parse) (vop-spec-arg spec '(or string null)))) (:arg-types - (setf (vop-parse-arg-types parse) (rest spec))) + (setf (vop-parse-arg-types parse) + (parse-operand-types (rest spec) t))) (:result-types - (setf (vop-parse-result-types parse) (rest spec))) + (setf (vop-parse-result-types parse) + (parse-operand-types (rest spec) nil))) (:translate (setf (vop-parse-translate parse) (rest spec))) (:guard @@ -1189,92 +1349,153 @@ ;;;; Make costs and restrictions: -(defconstant no-restriction - (make-array sc-number-limit :element-type 'bit :initial-element 1)) +;;; Compute-Loading-Costs -- Internal +;;; +;;; Given an operand, returns two values: +;;; 1] A SC-vector of the cost for the operand being in that SC, including both +;;; the costs for load functions and coercion VOPs. +;;; 2] A SC-vector holding the SC that we load into, for any SC that we can +;;; directly load from. +;;; +;;; In both vectors, unused entries are NIL. Load-P specifies the direction: +;;; if true, we are loading, if false we are saving. +;;; +(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))) + (dolist (sc-name scs) + (let* ((load-sc (sc-or-lose sc-name)) + (load-scn (sc-number load-sc))) + (setf (svref costs load-scn) 0) + (setf (svref load-scs load-scn) load-scn) + (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 load 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))) + + (setf (svref load-scs op-scn) load-scn))) + + (dotimes (i sc-number-limit) + (unless (svref costs i) + (let ((op-sc (svref *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))) + (defconstant no-costs (make-array sc-number-limit :initial-element 0)) +(defconstant no-loads + (let ((res (make-array sc-number-limit))) + (dotimes (i sc-number-limit) + (setf (svref res i) i)) + res)) -;;; Compute-Loading-Costs -- Internal + +;;; COMPUTE-LOADING-COSTS-IF-ANY -- 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. +;;; Pick off the case of operands with no restrictions. ;;; -(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) +(defun compute-loading-costs-if-any (op load-p) (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))) + (if (operand-parse-scs op) + (compute-loading-costs op load-p) + (values no-costs no-loads))) + + +;;; COMPUTE-COSTS-AND-RESTRICTIONS-LIST -- Internal +;;; +(defun compute-costs-and-restrictions-list (ops load-p) + (declare (list ops)) + (collect ((costs) + (scs)) + (dolist (op ops) + (multiple-value-bind (costs scs) + (compute-loading-costs-if-any op load-p) + (costs costs) + (scs scs))) + (values (costs) (scs)))) ;;; 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)))) + (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) + `( + :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))))) ;;;; Operand checking and stuff: +;;; PARSE-OPERAND-TYPES -- Internal +;;; +;;; Given a list of arg/result restrictions, check for valid syntax and +;;; convert to canonical form. +;;; +(defun parse-operand-types (specs args-p) + (declare (list specs)) + (mapcar #'(lambda (spec) + (cond ((eq spec '*) spec) + ((symbolp spec) + `(:or ,spec)) + ((atom spec) + (error "Bad thing to be a operand type: ~S." spec)) + (t + (case (first spec) + (:or + (unless (every #'symbolp (rest spec)) + (error "Bad PRIMITIVE-TYPE name in ~S." spec)) + spec) + (: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)))))) + specs)) + + ;;; Check-Operand-Types -- Internal ;;; ;;; If the operand types are specified, then check the number specified @@ -1286,9 +1507,15 @@ (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))) + (unless (eq types :unspecified) + (let ((num (+ (length ops) (if more-op 1 0)))) + (unless (= (length types) num) + (error "Expected ~D ~A type~P: ~S." num what 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."))))) + (undefined-value)) @@ -1365,18 +1592,33 @@ ;;; Make-Operand-Type -- Internal ;;; +;;; Return a form that can be evaluated to get the TEMPLATE operand type +;;; restriction from the given specification. +;;; (defun make-operand-type (type) - (if (eq type '*) - ''* - `(primitive-type-or-lose ',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))))))) + ;;; 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) + (make-list (+ (length ops) (if more-ops 1 0)) :initial-element '*) types)) + ;;; Make-VOP-Info-Types -- Internal ;;; ;;; Return a list of forms to use as keyword args to Make-VOP-Info for @@ -1463,6 +1705,7 @@ :info-arg-count ,(length (vop-parse-info-args parse)) :policy ',(vop-parse-policy parse) :save-p ',(vop-parse-save-p parse) + :move-args ',(vop-parse-move-args parse) :effects (vop-attributes ,@(vop-parse-effects parse)) :affected (vop-attributes ,@(vop-parse-affected parse)) ,@(make-costs-and-restrictions parse) @@ -1494,7 +1737,13 @@ (flet ((frob (x) (if (eq x '*) 't - (type-specifier (primitive-type-type x))))) + (ecase (first x) + (:or `(or ,@(mapcar #'(lambda (type) + (type-specifier + (primitive-type-type + type))) + (rest x)))) + (:constant `(constant ,(third x))))))) `(,@(mapcar #'frob types) ,@(when more-types `(&rest ,(frob more-types))))))) @@ -1532,11 +1781,21 @@ 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. + penalized according to move costs. A load TN will be allocated if + necessary, guaranteeing that the operand is always one of the + specified SCs. + + :Load-TN Load-Name + Load-Name is bound to the load TN allocated for this operand, or to + NIL if no load TN was allocated. + + :Load-If Expression + Controls whether automatic operand loading is done. Expression is + evaluated with the fixed operand TNs bound. If Expression is true, + then loading is done and the variable is bound to the load TN in + the generator body. Otherwise, loading is not done, and the variable + is bound to the actual operand. :More T-or-NIL If specified, Name is bound to the TN-Ref for the first argument or @@ -1546,13 +1805,21 @@ :Target Operand This operand is targeted to the named operand, indicating a desire to pack in the same location. Not legal for results. - + + :From Time-Spec + :To Time-Spec + Specify the beginning or end of the operand's lifetime. :From can + only be used with results, and :To only with arguments. The default + for the N'th argument/result is (:ARGUMENT N)/(:RESULT N). These + options are necessary primarily when operands are read or written out + of order. + :Conditional - This is used in place of :Results with conditional branch VOPs. There - are no result values: the result is a transfer of control. The - 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. + This is used in place of :RESULTS with conditional branch VOPs. There + are no result values: the result is a transfer of control. The target + label is passed as the first :INFO arg. The second :INFO arg is true if + the sense of the test should be negated. A side-effect is to set the + PREDICATE attribute for functions in the :TRANSLATE option. :Temporary ({Key Value}*) Name* Allocate a temporary TN for each Name, binding that variable to the TN @@ -1560,26 +1827,22 @@ 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. + specified offset. Offset is evaluated at macroexpand time. If + Offset is emitted, the register allocator chooses a free location in + SC. If both SC and Offset are omitted, then the temporary is packed + according to its primitive type. :From Time-Spec :To Time-Spec - 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). - + Similar to the argument/result option, this specifies the start and + end of the temporarys' lives. The defaults are :Load and :Save, i.e. + the duration of the VOP. The other intervening phases are :Argument, + :Eval and :Result. Non-zero sub-phases can be specified by a list, + e.g. by default the second argument's life ends at (:Argument 1). + :Generator Cost Form* Specifies the translation into assembly code. Cost is the estimated cost of the code emitted by this generator. The body is arbitrary Lisp code @@ -1616,14 +1879,19 @@ Specifies the cost of this VOP, overriding the cost of any inherited generator. - :Note String + :Note {String | NIL} A short noun-like phrase describing what this VOP \"does\", i.e. the - implementation strategy. This is for use in efficiency notes. + implementation strategy. If supplied, efficency notes will be generated + when type uncertainty prevents :TRANSLATE from working. NIL inhibits any + efficency note. - :Arg-Types Type* - :Result-Types Type* + :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. + If there is a :More operand, the last type is the more type. :CONSTANT + specifies that the argument must be a compile-time constant of the + specified Lisp type. The constant values of :CONSTANT arguments are + passed as additional :INFO arguments rather than as :ARGS. :Translate Name* This option causes the VOP template to be entered as an IR2 translation @@ -1643,8 +1911,11 @@ generated this VOP. :Save-P {NIL | T | :Compute-Only | :Force-To-Stack} - Indicates how a VOP wants live registers saved." - + Indicates how a VOP wants live registers saved. + + :Move-Args {NIL | :Full-Call | :Local-Call | :Known-Return} + Indicates if and how the more args should be moved into a different + frame." (check-type name symbol) (let* ((iparse (when inherits @@ -1919,6 +2190,13 @@ `(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)) + ;; ;; Do environment-live TNs. (dolist (,tn-var (ir2-environment-live-tns (environment-info @@ -1939,9 +2217,9 @@ ;; ;; Do TNs locally live in the designated live set. (dotimes (,i (ir2-block-local-tn-count ,n-block) ,result) - (let ((,tn-var (svref ,ltns ,i))) - (when (and ,tn-var (not (eq ,tn-var :more))) - (unless (zerop (sbit ,n-live ,i)) + (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))))))))))) @@ -1952,17 +2230,18 @@ "DO-ENVIRONMENT-IR2-BLOCKS (Block-Var Env [Result]) Form* Iterate over all the IR2 blocks in the environment Env, in emit order." (once-only ((n-env env)) - (once-only ((n-tail `(block-info - (component-tail - (block-component - (node-block - (lambda-bind (environment-function ,n-env)))))))) - `(do ((,block-var (block-info (node-block (lambda-bind fun))) - (ir2-block-next ,block-var))) - ((or (eq ,block-var ,n-tail) - (not (eq (ir2-block-environment ,block-var) ,n-env))) - ,result) - ,@body)))) + (once-only ((n-first `(node-block + (lambda-bind + (environment-function ,n-env))))) + (once-only ((n-tail `(block-info + (component-tail + (block-component ,n-first))))) + `(do ((,block-var (block-info ,n-first) + (ir2-block-next ,block-var))) + ((or (eq ,block-var ,n-tail) + (not (eq (ir2-block-environment ,block-var) ,n-env))) + ,result) + ,@body))))) ;;; NOTE-THIS-LOCATION -- Interface