X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmeta-vmdef.lisp;h=98c4600c2f1a592aedfed91ea866dd4ba5029fdf;hb=4ba392170e98744f0ef0b8e08a5d42b988f1d0c9;hp=f306deac692460c7d56bd1141897c2bbda654c55;hpb=fc999187f3f80dfcf170348df676386b8403e261;p=sbcl.git diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp index f306dea..98c4600 100644 --- a/src/compiler/meta-vmdef.lisp +++ b/src/compiler/meta-vmdef.lisp @@ -27,7 +27,8 @@ ;;; ;;; We enter the basic structure at meta-compile time, and then fill ;;; in the missing slots at load time. -(defmacro define-storage-base (name kind &key size) +(defmacro define-storage-base (name kind &key size (size-increment size) + (size-alignment 1)) (declare (type symbol name)) (declare (type (member :finite :unbounded :non-packed) kind)) @@ -39,47 +40,55 @@ (error "A size specification is meaningless in a ~S SB." kind))) ((:finite :unbounded) (unless size (error "Size is not specified in a ~S SB." kind)) - (aver (typep size 'unsigned-byte)))) + (aver (typep size 'unsigned-byte)) + (aver (= 1 (logcount size-alignment))) + (aver (not (logtest size (1- size-alignment)))) + (aver (not (logtest size-increment (1- size-alignment)))))) (let ((res (if (eq kind :non-packed) - (make-sb :name name :kind kind) - (make-finite-sb :name name :kind kind :size size)))) + (make-sb :name name :kind kind) + (make-finite-sb :name name :kind kind :size size + :size-increment size-increment + :size-alignment size-alignment)))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) - (/show0 "about to SETF GETHASH META-SB-NAMES in DEFINE-STORAGE-BASE") - (setf (gethash ',name *backend-meta-sb-names*) - ',res)) + (/show0 "about to SETF GETHASH META-SB-NAMES in DEFINE-STORAGE-BASE") + (setf (gethash ',name *backend-meta-sb-names*) + ',res)) (/show0 "about to SETF GETHASH SB-NAMES in DEFINE-STORAGE-BASE") ,(if (eq kind :non-packed) - `(setf (gethash ',name *backend-sb-names*) - (copy-sb ',res)) - `(let ((res (copy-finite-sb ',res))) - (/show0 "not :NON-PACKED, i.e. hairy case") - (setf (finite-sb-always-live res) - (make-array ',size - :initial-element - #-(or sb-xc sb-xc-host) #* - ;; The cross-compiler isn't very good - ;; at dumping specialized arrays; we - ;; work around that by postponing - ;; generation of the specialized - ;; array 'til runtime. - #+(or sb-xc sb-xc-host) - (make-array 0 :element-type 'bit))) - (/show0 "doing second SETF") - (setf (finite-sb-conflicts res) - (make-array ',size :initial-element '#())) - (/show0 "doing third SETF") - (setf (finite-sb-live-tns res) - (make-array ',size :initial-element nil)) - (/show0 "doing fourth and final SETF") - (setf (gethash ',name *backend-sb-names*) - res))) + `(setf (gethash ',name *backend-sb-names*) + (copy-sb ',res)) + `(let ((res (copy-finite-sb ',res))) + (/show0 "not :NON-PACKED, i.e. hairy case") + (setf (finite-sb-always-live res) + (make-array ',size + :initial-element + #-(or sb-xc sb-xc-host) #* + ;; The cross-compiler isn't very good + ;; at dumping specialized arrays; we + ;; work around that by postponing + ;; generation of the specialized + ;; array 'til runtime. + #+(or sb-xc sb-xc-host) + (make-array 0 :element-type 'bit))) + (/show0 "doing second SETF") + (setf (finite-sb-conflicts res) + (make-array ',size :initial-element '#())) + (/show0 "doing third SETF") + (setf (finite-sb-live-tns res) + (make-array ',size :initial-element nil)) + (/show0 "doing fourth SETF") + (setf (finite-sb-always-live-count res) + (make-array ',size :initial-element 0)) + (/show0 "doing fifth and final SETF") + (setf (gethash ',name *backend-sb-names*) + res))) (/show0 "about to put SB onto/into SB-LIST") (setf *backend-sb-list* - (cons (sb-or-lose ',name) - (remove ',name *backend-sb-list* :key #'sb-name))) + (cons (sb-or-lose ',name) + (remove ',name *backend-sb-list* :key #'sb-name))) (/show0 "finished with DEFINE-STORAGE-BASE expansion") ',name))) @@ -119,8 +128,8 @@ ;;; A list of the names of all the constant SCs that can be loaded into this ;;; SC by a move function. (defmacro define-storage-class (name number sb-name &key (element-size '1) - (alignment '1) locations reserve-locations - save-p alternate-scs constant-scs) + (alignment '1) locations reserve-locations + save-p alternate-scs constant-scs) (declare (type symbol name)) (declare (type sc-number number)) (declare (type symbol sb-name)) @@ -131,59 +140,59 @@ (let ((sb (meta-sb-or-lose sb-name))) (if (eq (sb-kind sb) :finite) - (let ((size (sb-size sb)) - (element-size (eval element-size))) - (declare (type unsigned-byte element-size)) - (dolist (el locations) - (declare (type unsigned-byte el)) - (unless (<= 1 (+ el element-size) size) - (error "SC element ~W out of bounds for ~S" el sb)))) - (when locations - (error ":LOCATIONS is meaningless in a ~S SB." (sb-kind sb)))) + (let ((size (sb-size sb)) + (element-size (eval element-size))) + (declare (type unsigned-byte element-size)) + (dolist (el locations) + (declare (type unsigned-byte el)) + (unless (<= 1 (+ el element-size) size) + (error "SC element ~W out of bounds for ~S" el sb)))) + (when locations + (error ":LOCATIONS is meaningless in a ~S SB." (sb-kind sb)))) (unless (subsetp reserve-locations locations) (error "RESERVE-LOCATIONS not a subset of LOCATIONS.")) (when (and (or alternate-scs constant-scs) - (eq (sb-kind sb) :non-packed)) + (eq (sb-kind sb) :non-packed)) (error "It's meaningless to specify alternate or constant SCs in a ~S SB." (sb-kind sb)))) (let ((nstack-p - (if (or (eq sb-name 'non-descriptor-stack) - (find 'non-descriptor-stack - (mapcar #'meta-sc-or-lose alternate-scs) - :key (lambda (x) - (sb-name (sc-sb x))))) - t nil))) + (if (or (eq sb-name 'non-descriptor-stack) + (find 'non-descriptor-stack + (mapcar #'meta-sc-or-lose alternate-scs) + :key (lambda (x) + (sb-name (sc-sb x))))) + t nil))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) - (let ((res (make-sc :name ',name :number ',number - :sb (meta-sb-or-lose ',sb-name) - :element-size ,element-size - :alignment ,alignment - :locations ',locations - :reserve-locations ',reserve-locations - :save-p ',save-p - :number-stack-p ,nstack-p - :alternate-scs (mapcar #'meta-sc-or-lose - ',alternate-scs) - :constant-scs (mapcar #'meta-sc-or-lose - ',constant-scs)))) - (setf (gethash ',name *backend-meta-sc-names*) res) - (setf (svref *backend-meta-sc-numbers* ',number) res) - (setf (svref (sc-load-costs res) ',number) 0))) + (let ((res (make-sc :name ',name :number ',number + :sb (meta-sb-or-lose ',sb-name) + :element-size ,element-size + :alignment ,alignment + :locations ',locations + :reserve-locations ',reserve-locations + :save-p ',save-p + :number-stack-p ,nstack-p + :alternate-scs (mapcar #'meta-sc-or-lose + ',alternate-scs) + :constant-scs (mapcar #'meta-sc-or-lose + ',constant-scs)))) + (setf (gethash ',name *backend-meta-sc-names*) res) + (setf (svref *backend-meta-sc-numbers* ',number) res) + (setf (svref (sc-load-costs res) ',number) 0))) (let ((old (svref *backend-sc-numbers* ',number))) - (when (and old (not (eq (sc-name old) ',name))) - (warn "redefining SC number ~W from ~S to ~S" ',number - (sc-name old) ',name))) + (when (and old (not (eq (sc-name old) ',name))) + (warn "redefining SC number ~W from ~S to ~S" ',number + (sc-name old) ',name))) (setf (svref *backend-sc-numbers* ',number) - (meta-sc-or-lose ',name)) + (meta-sc-or-lose ',name)) (setf (gethash ',name *backend-sc-names*) - (meta-sc-or-lose ',name)) + (meta-sc-or-lose ',name)) (setf (sc-sb (sc-or-lose ',name)) (sb-or-lose ',sb-name)) ',name))) @@ -193,13 +202,13 @@ ;;; etc.), bind TO-SC and FROM-SC to all the combinations. (defmacro do-sc-pairs ((from-sc-var to-sc-var scs) &body body) `(do ((froms ,scs (cddr froms)) - (tos (cdr ,scs) (cddr tos))) + (tos (cdr ,scs) (cddr tos))) ((null froms)) (dolist (from (car froms)) (let ((,from-sc-var (meta-sc-or-lose from))) - (dolist (to (car tos)) - (let ((,to-sc-var (meta-sc-or-lose to))) - ,@body)))))) + (dolist (to (car tos)) + (let ((,to-sc-var (meta-sc-or-lose to))) + ,@body)))))) ;;; Define the function NAME and note it as the function used for ;;; moving operands from the From-SCs to the To-SCs. Cost is the cost @@ -215,14 +224,14 @@ `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (do-sc-pairs (from-sc to-sc ',scs) - (unless (eq from-sc to-sc) - (let ((num (sc-number from-sc))) - (setf (svref (sc-move-funs to-sc) num) ',name) - (setf (svref (sc-load-costs to-sc) num) ',cost))))) + (unless (eq from-sc to-sc) + (let ((num (sc-number from-sc))) + (setf (svref (sc-move-funs to-sc) num) ',name) + (setf (svref (sc-load-costs to-sc) num) ',cost))))) (defun ,name ,lambda-list (sb!assem:assemble (*code-segment* ,(first lambda-list)) - ,@body)))) + ,@body)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *sc-vop-slots* @@ -241,34 +250,34 @@ (when (or (oddp (length scs)) (null scs)) (error "malformed SCs spec: ~S" scs)) (let ((accessor (or (cdr (assoc kind *sc-vop-slots*)) - (error "unknown kind ~S" kind)))) + (error "unknown kind ~S" kind)))) `(progn ,@(when (eq kind :move) - `((eval-when (:compile-toplevel :load-toplevel :execute) - (do-sc-pairs (from-sc to-sc ',scs) - (compute-move-costs from-sc to-sc - ,(vop-parse-cost - (vop-parse-or-lose name))))))) + `((eval-when (:compile-toplevel :load-toplevel :execute) + (do-sc-pairs (from-sc to-sc ',scs) + (compute-move-costs from-sc to-sc + ,(vop-parse-cost + (vop-parse-or-lose name))))))) (let ((vop (template-or-lose ',name))) - (do-sc-pairs (from-sc to-sc ',scs) - (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc))) - (let ((vec (,accessor dest-sc))) - (let ((scn (sc-number from-sc))) - (setf (svref vec scn) - (adjoin-template vop (svref vec scn)))) - (dolist (sc (append (sc-alternate-scs from-sc) - (sc-constant-scs from-sc))) - (let ((scn (sc-number sc))) - (setf (svref vec scn) - (adjoin-template vop (svref vec scn)))))))))))) + (do-sc-pairs (from-sc to-sc ',scs) + (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc))) + (let ((vec (,accessor dest-sc))) + (let ((scn (sc-number from-sc))) + (setf (svref vec scn) + (adjoin-template vop (svref vec scn)))) + (dolist (sc (append (sc-alternate-scs from-sc) + (sc-constant-scs from-sc))) + (let ((scn (sc-number sc))) + (setf (svref vec scn) + (adjoin-template vop (svref vec scn)))))))))))) ;;;; primitive type definition (defun meta-primitive-type-or-lose (name) (the primitive-type (or (gethash name *backend-meta-primitive-type-names*) - (error "~S is not a defined primitive type." name)))) + (error "~S is not a defined primitive type." name)))) ;;; Define a primitive type NAME. Each SCS entry specifies a storage ;;; class that values of this type may be allocated in. TYPE is the @@ -280,33 +289,33 @@ (/show0 "doing !DEF-PRIMITIVE-TYPE, NAME=..") (/primitive-print ,(symbol-name name)) (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) - (setf (gethash ',name *backend-meta-primitive-type-names*) - (make-primitive-type :name ',name - :scs ',scns - :specifier ',type))) + (setf (gethash ',name *backend-meta-primitive-type-names*) + (make-primitive-type :name ',name + :scs ',scns + :specifier ',type))) ,(once-only ((n-old `(gethash ',name *backend-primitive-type-names*))) - `(progn - ;; If the PRIMITIVE-TYPE structure already exists, we - ;; destructively modify it so that existing references in - ;; templates won't be invalidated. FIXME: This should no - ;; longer be an issue in SBCL, since we don't try to do - ;; serious surgery on ourselves. Probably this should - ;; just become an assertion that N-OLD is NIL, so that we - ;; don't have to try to maintain the correctness of the - ;; never-ordinarily-used clause. - (/show0 "in !DEF-PRIMITIVE-TYPE, about to COND") - (cond (,n-old - (/show0 "in ,N-OLD clause of COND") - (setf (primitive-type-scs ,n-old) ',scns) - (setf (primitive-type-specifier ,n-old) ',type)) - (t - (/show0 "in T clause of COND") - (setf (gethash ',name *backend-primitive-type-names*) - (make-primitive-type :name ',name - :scs ',scns - :specifier ',type)))) - (/show0 "done with !DEF-PRIMITIVE-TYPE") - ',name))))) + `(progn + ;; If the PRIMITIVE-TYPE structure already exists, we + ;; destructively modify it so that existing references in + ;; templates won't be invalidated. FIXME: This should no + ;; longer be an issue in SBCL, since we don't try to do + ;; serious surgery on ourselves. Probably this should + ;; just become an assertion that N-OLD is NIL, so that we + ;; don't have to try to maintain the correctness of the + ;; never-ordinarily-used clause. + (/show0 "in !DEF-PRIMITIVE-TYPE, about to COND") + (cond (,n-old + (/show0 "in ,N-OLD clause of COND") + (setf (primitive-type-scs ,n-old) ',scns) + (setf (primitive-type-specifier ,n-old) ',type)) + (t + (/show0 "in T clause of COND") + (setf (gethash ',name *backend-primitive-type-names*) + (make-primitive-type :name ',name + :scs ',scns + :specifier ',type)))) + (/show0 "done with !DEF-PRIMITIVE-TYPE") + ',name))))) ;;; Define NAME to be an alias for RESULT in VOP operand type restrictions. (defmacro !def-primitive-type-alias (name result) @@ -328,19 +337,19 @@ ;;; result, checking that the value is of this type in the process. (defmacro primitive-type-vop (vop kinds &rest types) (let ((n-vop (gensym)) - (n-type (gensym))) + (n-type (gensym))) `(let ((,n-vop (template-or-lose ',vop))) ,@(mapcar - (lambda (type) - `(let ((,n-type (primitive-type-or-lose ',type))) - ,@(mapcar - (lambda (kind) - (let ((slot (or (cdr (assoc kind - *primitive-type-slot-alist*)) - (error "unknown kind: ~S" kind)))) - `(setf (,slot ,n-type) ,n-vop))) - kinds))) - types) + (lambda (type) + `(let ((,n-type (primitive-type-or-lose ',type))) + ,@(mapcar + (lambda (kind) + (let ((slot (or (cdr (assoc kind + *primitive-type-slot-alist*)) + (error "unknown kind: ~S" kind)))) + `(setf (,slot ,n-type) ,n-vop))) + kinds))) + types) nil))) ;;; Return true if SC is either one of PTYPE's SC's, or one of those @@ -350,11 +359,11 @@ (let ((scn (sc-number sc))) (dolist (allowed (primitive-type-scs ptype) nil) (when (eql allowed scn) - (return t)) + (return t)) (let ((allowed-sc (svref *backend-meta-sc-numbers* allowed))) - (when (or (member sc (sc-alternate-scs allowed-sc)) - (member sc (sc-constant-scs allowed-sc))) - (return t)))))) + (when (or (member sc (sc-alternate-scs allowed-sc)) + (member sc (sc-constant-scs allowed-sc))) + (return t)))))) ;;;; VOP definition structures ;;;; @@ -366,8 +375,8 @@ ;;; A VOP-PARSE object holds everything we need to know about a VOP at ;;; meta-compile time. (def!struct (vop-parse - (:make-load-form-fun just-dump-it-normally) - #-sb-xc-host (:pure t)) + (:make-load-form-fun just-dump-it-normally) + #-sb-xc-host (:pure t)) ;; the name of this VOP (name nil :type symbol) ;; If true, then the name of the VOP we inherit from. @@ -386,7 +395,9 @@ (operands nil :type list) ;; names of variables that should be declared IGNORE (ignores () :type list) - ;; true if this is a :CONDITIONAL VOP + ;; true if this is a :CONDITIONAL VOP. T if a branchful VOP, + ;; a list of condition descriptor otherwise. See $ARCH/pred.lisp + ;; for more information. (conditional-p nil) ;; argument and result primitive types. These are pulled out of the ;; operands, since we often want to change them without respecifying @@ -404,7 +415,7 @@ (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) @@ -412,8 +423,8 @@ (note nil :type (or string null)) ;; a list of the names of the Effects and Affected attributes for ;; this VOP - (effects '(any) :type list) - (affected '(any) :type list) + (effects '#1=(any) :type list) + (affected '#1# :type list) ;; a list of the names of functions this VOP is a translation of and ;; the policy that allows this translation to be done. :FAST is a ;; safe default, since it isn't a safe policy. @@ -453,22 +464,19 @@ ;;; operand or temporary at meta-compile time. Besides the obvious ;;; stuff, we also store the names of per-operand temporaries here. (def!struct (operand-parse - (:make-load-form-fun just-dump-it-normally) - #-sb-xc-host (:pure t)) + (:make-load-form-fun just-dump-it-normally) + #-sb-xc-host (:pure t)) ;; name of the operand (which we bind to the TN) (name nil :type symbol) ;; the way this operand is used: (kind (missing-arg) - :type (member :argument :result :temporary - :more-argument :more-result)) + :type (member :argument :result :temporary + :more-argument :more-result)) ;; If true, the name of an operand that this operand is targeted to. ;; This is only meaningful in :ARGUMENT and :TEMPORARY operands. (target nil :type (or symbol null)) ;; TEMP is a temporary that holds the TN-REF for this operand. - ;; TEMP-TEMP holds the write reference that begins a temporary's - ;; lifetime. - (temp (gensym) :type symbol) - (temp-temp nil :type (or symbol null)) + (temp (make-operand-parse-temp) :type symbol) ;; the time that this operand is first live and the time at which it ;; becomes dead again. These are TIME-SPECs, as returned by ;; PARSE-TIME-SPEC. @@ -479,7 +487,7 @@ (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 @@ -505,16 +513,16 @@ ;;; the operand kind isn't one of the specified Kinds. If Error-P is ;;; NIL, just return NIL if there is no such operand. (defun find-operand (name parse &optional - (kinds '(:argument :result :temporary)) - (error-p t)) + (kinds '(:argument :result :temporary)) + (error-p t)) (declare (symbol name) (type vop-parse parse) (list kinds)) (let ((found (find name (vop-parse-operands parse) - :key #'operand-parse-name))) + :key #'operand-parse-name))) (if found - (unless (member (operand-parse-kind found) kinds) - (error "Operand ~S isn't one of these kinds: ~S." name kinds)) - (when error-p - (error "~S is not an operand to ~S." name (vop-parse-name parse)))) + (unless (member (operand-parse-kind found) kinds) + (error "Operand ~S isn't one of these kinds: ~S." name kinds)) + (when error-p + (error "~S is not an operand to ~S." name (vop-parse-name parse)))) found)) ;;; Get the VOP-PARSE structure for NAME or die trying. For all @@ -523,28 +531,28 @@ (defun vop-parse-or-lose (name) (the vop-parse (or (gethash name *backend-parsed-vops*) - (error "~S is not the name of a defined VOP." name)))) + (error "~S is not the name of a defined VOP." name)))) ;;; Return a list of LET-forms to parse a TN-REF list into the temps ;;; specified by the operand-parse structures. MORE-OPERAND is the -;;; Operand-Parse describing any more operand, or NIL if none. REFS is -;;; an expression that evaluates into the first tn-ref. +;;; OPERAND-PARSE describing any more operand, or NIL if none. REFS is +;;; an expression that evaluates into the first TN-REF. (defun access-operands (operands more-operand refs) (declare (list operands)) (collect ((res)) (let ((prev refs)) (dolist (op operands) - (let ((n-ref (operand-parse-temp op))) - (res `(,n-ref ,prev)) - (setq prev `(tn-ref-across ,n-ref)))) + (let ((n-ref (operand-parse-temp op))) + (res `(,n-ref ,prev)) + (setq prev `(tn-ref-across ,n-ref)))) (when more-operand - (res `(,(operand-parse-name more-operand) ,prev)))) + (res `(,(operand-parse-name more-operand) ,prev)))) (res))) ;;; This is used with ACCESS-OPERANDS to prevent warnings for TN-REF ;;; 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))))) @@ -558,7 +566,7 @@ (error "extra junk at end of ~S" spec)) (let ((thing (elt spec n))) (unless (typep thing type) - (error "~:R argument is not a ~S: ~S" n type spec)) + (error "~:R argument is not a ~S: ~S" n type spec)) thing))) ;;;; time specs @@ -571,161 +579,143 @@ (defun parse-time-spec (spec) (let ((dspec (if (atom spec) (list spec 0) spec))) (unless (and (= (length dspec) 2) - (typep (second dspec) 'unsigned-byte)) + (typep (second dspec) 'unsigned-byte)) (error "malformed time specifier: ~S" spec)) (cons (case (first dspec) - (:load 0) - (:argument 1) - (:eval 2) - (:result 3) - (:save 4) - (t - (error "unknown phase in time specifier: ~S" spec))) - (second dspec)))) + (:load 0) + (:argument 1) + (:eval 2) + (:result 3) + (:save 4) + (t + (error "unknown phase in time specifier: ~S" spec))) + (second dspec)))) ;;; Return true if the time spec X is the same or later time than Y. (defun time-spec-order (x y) (or (> (car x) (car y)) (and (= (car x) (car y)) - (>= (cdr x) (cdr y))))) + (>= (cdr x) (cdr y))))) ;;;; generation of emit functions (defun compute-temporaries-description (parse) (let ((temps (vop-parse-temps parse)) - (element-type '(unsigned-byte 16))) + (element-type '(unsigned-byte 16))) (when temps (let ((results (make-specializable-array - (length temps) - :element-type element-type)) - (index 0)) - (dolist (temp temps) - (declare (type operand-parse temp)) - (let ((sc (operand-parse-sc temp)) - (offset (operand-parse-offset temp))) - (aver sc) - (setf (aref results index) - (if offset - (+ (ash offset (1+ sc-bits)) - (ash (meta-sc-number-or-lose sc) 1) - 1) - (ash (meta-sc-number-or-lose sc) 1)))) - (incf index)) - ;; KLUDGE: As in the other COERCEs wrapped around with - ;; MAKE-SPECIALIZABLE-ARRAY results in COMPUTE-REF-ORDERING, - ;; this coercion could be removed by a sufficiently smart - ;; compiler, but I dunno whether Python is that smart. It - ;; would be good to check this and help it if it's not smart - ;; enough to remove it for itself. However, it's probably not - ;; urgent, since the overhead of an extra no-op conversion is - ;; unlikely to be large compared to consing and corresponding - ;; GC. -- WHN ca. 19990701 - `(coerce ,results '(specializable-vector ,element-type)))))) + (length temps) + :element-type element-type)) + (index 0)) + (dolist (temp temps) + (declare (type operand-parse temp)) + (let ((sc (operand-parse-sc temp)) + (offset (operand-parse-offset temp))) + (aver sc) + (setf (aref results index) + (if offset + (+ (ash offset (1+ sc-bits)) + (ash (meta-sc-number-or-lose sc) 1) + 1) + (ash (meta-sc-number-or-lose sc) 1)))) + (incf index)) + ;; KLUDGE: The load-time MAKE-ARRAY here is an artifact of our + ;; cross-compilation strategy, and the conservative + ;; assumptions we are forced to make on which specialized + ;; arrays exist on the host lisp that the cross-compiler is + ;; running on. (We used to use COERCE here, but that caused + ;; SUBTYPEP calls too early in cold-init for comfort). -- + ;; CSR, 2009-10-30 + `(make-array ,(length results) :element-type '(specializable ,element-type) :initial-contents ',results))))) (defun compute-ref-ordering (parse) (let* ((num-args (+ (length (vop-parse-args parse)) - (if (vop-parse-more-args parse) 1 0))) - (num-results (+ (length (vop-parse-results parse)) - (if (vop-parse-more-results parse) 1 0))) - (index 0)) + (if (vop-parse-more-args parse) 1 0))) + (num-results (+ (length (vop-parse-results parse)) + (if (vop-parse-more-results parse) 1 0))) + (index 0)) (collect ((refs) (targets)) (dolist (op (vop-parse-operands parse)) - (when (operand-parse-target op) - (unless (member (operand-parse-kind op) '(:argument :temporary)) - (error "cannot target a ~S operand: ~S" (operand-parse-kind op) - (operand-parse-name op))) - (let ((target (find-operand (operand-parse-target op) parse - '(:temporary :result)))) - ;; KLUDGE: These formulas must be consistent with those in - ;; %EMIT-GENERIC-VOP, and this is currently maintained by - ;; hand. -- WHN 2002-01-30, paraphrasing APD - (targets (+ (* index max-vop-tn-refs) - (ecase (operand-parse-kind target) - (:result - (+ (position-or-lose target - (vop-parse-results parse)) - num-args)) - (:temporary - (+ (* (position-or-lose target - (vop-parse-temps parse)) - 2) + (when (operand-parse-target op) + (unless (member (operand-parse-kind op) '(:argument :temporary)) + (error "cannot target a ~S operand: ~S" (operand-parse-kind op) + (operand-parse-name op))) + (let ((target (find-operand (operand-parse-target op) parse + '(:temporary :result)))) + ;; KLUDGE: These formulas must be consistent with those in + ;; EMIT-VOP, and this is currently maintained by + ;; hand. -- WHN 2002-01-30, paraphrasing APD + (targets (+ (* index max-vop-tn-refs) + (ecase (operand-parse-kind target) + (:result + (+ (position-or-lose target + (vop-parse-results parse)) + num-args)) + (:temporary + (+ (* (position-or-lose target + (vop-parse-temps parse)) + 2) 1 - num-args - num-results))))))) - (let ((born (operand-parse-born op)) - (dies (operand-parse-dies op))) - (ecase (operand-parse-kind op) - (:argument - (refs (cons (cons dies nil) index))) - (:more-argument - (refs (cons (cons dies nil) index))) - (:result - (refs (cons (cons born t) index))) - (:more-result - (refs (cons (cons born t) index))) - (:temporary - (refs (cons (cons dies nil) index)) - (incf index) - (refs (cons (cons born t) index)))) - (incf index))) - (let* ((sorted (sort (refs) - (lambda (x y) - (let ((x-time (car x)) - (y-time (car y))) - (if (time-spec-order x-time y-time) - (if (time-spec-order y-time x-time) - (and (not (cdr x)) (cdr y)) - nil) - t))) - :key #'car)) - ;; :REF-ORDERING element type - ;; - ;; KLUDGE: was (MOD #.MAX-VOP-TN-REFS), which is still right - (oe-type '(unsigned-byte 8)) - ;; :TARGETS element-type - ;; - ;; KLUDGE: was (MOD #.(* MAX-VOP-TN-REFS 2)), which does - ;; not correspond to the definition in - ;; src/compiler/vop.lisp. - (te-type '(unsigned-byte 16)) - (ordering (make-specializable-array - (length sorted) - :element-type oe-type))) - (let ((index 0)) - (dolist (ref sorted) - (setf (aref ordering index) (cdr ref)) - (incf index))) - `(:num-args ,num-args - :num-results ,num-results - ;; KLUDGE: The (COERCE .. (SPECIALIZABLE-VECTOR ..)) wrapper - ;; here around the result returned by - ;; MAKE-SPECIALIZABLE-ARRAY above was of course added to - ;; help with cross-compilation. "A sufficiently smart - ;; compiler" should be able to optimize all this away in the - ;; final target Lisp, leaving a single MAKE-ARRAY with no - ;; subsequent coercion. However, I don't know whether Python - ;; is that smart. (Can it figure out the return type of - ;; MAKE-ARRAY? Does it know that COERCE can be optimized - ;; away if the input type is known to be the same as the - ;; COERCEd-to type?) At some point it would be good to test - ;; to see whether this construct is in fact causing run-time - ;; overhead, and fix it if so. (Some declarations of the - ;; types returned by MAKE-ARRAY might be enough to fix it.) - ;; However, it's probably not urgent to fix this, since it's - ;; hard to imagine that any overhead caused by calling - ;; COERCE and letting it decide to bail out could be large - ;; compared to the cost of consing and GCing the vectors in - ;; the first place. -- WHN ca. 19990701 - :ref-ordering (coerce ',ordering - '(specializable-vector ,oe-type)) - ,@(when (targets) - `(:targets (coerce ',(targets) - '(specializable-vector ,te-type))))))))) + num-args + num-results))))))) + (let ((born (operand-parse-born op)) + (dies (operand-parse-dies op))) + (ecase (operand-parse-kind op) + (:argument + (refs (cons (cons dies nil) index))) + (:more-argument + (refs (cons (cons dies nil) index))) + (:result + (refs (cons (cons born t) index))) + (:more-result + (refs (cons (cons born t) index))) + (:temporary + (refs (cons (cons dies nil) index)) + (incf index) + (refs (cons (cons born t) index)))) + (incf index))) + (let* ((sorted (stable-sort (refs) + (lambda (x y) + (let ((x-time (car x)) + (y-time (car y))) + (if (time-spec-order x-time y-time) + (if (time-spec-order y-time x-time) + (and (not (cdr x)) (cdr y)) + nil) + t))) + :key #'car)) + ;; :REF-ORDERING element type + ;; + ;; KLUDGE: was (MOD #.MAX-VOP-TN-REFS), which is still right + (oe-type '(unsigned-byte 8)) + ;; :TARGETS element-type + ;; + ;; KLUDGE: was (MOD #.(* MAX-VOP-TN-REFS 2)), which does + ;; not correspond to the definition in + ;; src/compiler/vop.lisp. + (te-type '(unsigned-byte 16)) + (ordering (make-specializable-array + (length sorted) + :element-type oe-type))) + (let ((index 0)) + (dolist (ref sorted) + (setf (aref ordering index) (cdr ref)) + (incf index))) + `(:num-args ,num-args + :num-results ,num-results + ;; KLUDGE: see the comment regarding MAKE-ARRAY in + ;; COMPUTE-TEMPORARIES-DESCRIPTION. -- CSR, 2009-10-30 + :ref-ordering (make-array ,(length ordering) + :initial-contents ',ordering + :element-type '(specializable ,oe-type)) + ,@(when (targets) + `(:targets (make-array ,(length (targets)) + :initial-contents ',(targets) + :element-type '(specializable ,te-type))))))))) (defun make-emit-function-and-friends (parse) - `(:emit-function #'emit-generic-vop - :temps ,(compute-temporaries-description parse) + `(:temps ,(compute-temporaries-description parse) ,@(compute-ref-ordering parse))) ;;;; generator functions @@ -738,38 +728,38 @@ (collect ((funs)) (dolist (sc-name (operand-parse-scs op)) (let* ((sc (meta-sc-or-lose sc-name)) - (scn (sc-number sc)) - (load-scs (append (when load-p - (sc-constant-scs sc)) - (sc-alternate-scs sc)))) - (cond - (load-scs - (dolist (alt load-scs) - (unless (member (sc-name alt) (operand-parse-scs op) :test #'eq) - (let* ((altn (sc-number alt)) - (name (if load-p - (svref (sc-move-funs sc) altn) - (svref (sc-move-funs alt) scn))) - (found (or (assoc alt (funs) :test #'member) - (rassoc name (funs))))) - (unless name - (error "no move function defined to ~:[save~;load~] SC ~S ~ - with ~S ~:[to~;from~] from SC ~S" - load-p sc-name load-p (sc-name alt))) - - (cond (found - (unless (eq (cdr found) name) - (error "can't tell whether to ~:[save~;load~]~@ - or ~S when operand is in SC ~S" - load-p name (cdr found) (sc-name alt))) - (pushnew alt (car found))) - (t - (funs (cons (list alt) name)))))))) - ((member (sb-kind (sc-sb sc)) '(:non-packed :unbounded))) - (t - (error "SC ~S has no alternate~:[~; or constant~] SCs, yet it is~@ - mentioned in the restriction for operand ~S" - sc-name load-p (operand-parse-name op)))))) + (scn (sc-number sc)) + (load-scs (append (when load-p + (sc-constant-scs sc)) + (sc-alternate-scs sc)))) + (cond + (load-scs + (dolist (alt load-scs) + (unless (member (sc-name alt) (operand-parse-scs op) :test #'eq) + (let* ((altn (sc-number alt)) + (name (if load-p + (svref (sc-move-funs sc) altn) + (svref (sc-move-funs alt) scn))) + (found (or (assoc alt (funs) :test #'member) + (rassoc name (funs))))) + (unless name + (error "no move function defined to ~:[save~;load~] SC ~S ~ + ~:[to~;from~] from SC ~S" + load-p sc-name load-p (sc-name alt))) + + (cond (found + (unless (eq (cdr found) name) + (error "can't tell whether to ~:[save~;load~]~@ + with ~S or ~S when operand is in SC ~S" + load-p name (cdr found) (sc-name alt))) + (pushnew alt (car found))) + (t + (funs (cons (list alt) name)))))))) + ((member (sb-kind (sc-sb sc)) '(:non-packed :unbounded))) + (t + (error "SC ~S has no alternate~:[~; or constant~] SCs, yet it is~@ + mentioned in the restriction for operand ~S" + sc-name load-p (operand-parse-name op)))))) (funs))) ;;; Return a form to load/save the specified operand when it has a @@ -780,110 +770,120 @@ ;;; of the operand TN's type to see which move function to use. (defun call-move-fun (parse op load-p) (let ((funs (find-move-funs op load-p)) - (load-tn (operand-parse-load-tn op))) + (load-tn (operand-parse-load-tn op))) (if funs - (let* ((tn `(tn-ref-tn ,(operand-parse-temp op))) - (n-vop (or (vop-parse-vop-var parse) - (setf (vop-parse-vop-var parse) (gensym)))) - (form (if (rest funs) - `(sc-case ,tn - ,@(mapcar (lambda (x) - `(,(mapcar #'sc-name (car x)) - ,(if load-p - `(,(cdr x) ,n-vop ,tn - ,load-tn) - `(,(cdr x) ,n-vop ,load-tn - ,tn)))) - funs)) - (if load-p - `(,(cdr (first funs)) ,n-vop ,tn ,load-tn) - `(,(cdr (first funs)) ,n-vop ,load-tn ,tn))))) - (if (eq (operand-parse-load op) t) - `(when ,load-tn ,form) - `(when (eq ,load-tn ,(operand-parse-name op)) - ,form))) - `(when ,load-tn - (error "load TN allocated, but no move function?~@ - VM definition is inconsistent, recompile and try again."))))) + (let* ((tn `(tn-ref-tn ,(operand-parse-temp op))) + (n-vop (or (vop-parse-vop-var parse) + (setf (vop-parse-vop-var parse) '.vop.))) + (form (if (rest funs) + `(sc-case ,tn + ,@(mapcar (lambda (x) + `(,(mapcar #'sc-name (car x)) + ,(if load-p + `(,(cdr x) ,n-vop ,tn + ,load-tn) + `(,(cdr x) ,n-vop ,load-tn + ,tn)))) + funs)) + (if load-p + `(,(cdr (first funs)) ,n-vop ,tn ,load-tn) + `(,(cdr (first funs)) ,n-vop ,load-tn ,tn))))) + (if (eq (operand-parse-load op) t) + `(when ,load-tn ,form) + `(when (eq ,load-tn ,(operand-parse-name op)) + ,form))) + `(when ,load-tn + (error "load TN allocated, but no move function?~@ + VM definition is inconsistent, recompile and try again."))))) ;;; Return the TN that we should bind to the operand's var in the ;;; generator body. In general, this involves evaluating the :LOAD-IF ;;; test expression. (defun decide-to-load (parse op) (let ((load (operand-parse-load op)) - (load-tn (operand-parse-load-tn op)) - (temp (operand-parse-temp op))) + (load-tn (operand-parse-load-tn op)) + (temp (operand-parse-temp op))) (if (eq load t) - `(or ,load-tn (tn-ref-tn ,temp)) - (collect ((binds) - (ignores)) - (dolist (x (vop-parse-operands parse)) - (when (member (operand-parse-kind x) '(:argument :result)) - (let ((name (operand-parse-name x))) - (binds `(,name (tn-ref-tn ,(operand-parse-temp x)))) - (ignores name)))) - `(if (and ,load-tn - (let ,(binds) - (declare (ignorable ,@(ignores))) - ,load)) - ,load-tn - (tn-ref-tn ,temp)))))) + `(or ,load-tn (tn-ref-tn ,temp)) + (collect ((binds) + (ignores)) + (dolist (x (vop-parse-operands parse)) + (when (member (operand-parse-kind x) '(:argument :result)) + (let ((name (operand-parse-name x))) + (binds `(,name (tn-ref-tn ,(operand-parse-temp x)))) + (ignores name)))) + `(if (and ,load-tn + (let ,(binds) + (declare (ignorable ,@(ignores))) + ,load)) + ,load-tn + (tn-ref-tn ,temp)))))) ;;; Make a lambda that parses the VOP TN-REFS, does automatic operand ;;; loading, and runs the appropriate code generator. (defun make-generator-function (parse) (declare (type vop-parse parse)) (let ((n-vop (vop-parse-vop-var parse)) - (operands (vop-parse-operands parse)) - (n-info (gensym)) (n-variant (gensym))) + (operands (vop-parse-operands parse)) + (n-info (gensym)) (n-variant (gensym))) (collect ((binds) - (loads) - (saves)) + (loads) + (saves)) (dolist (op operands) - (ecase (operand-parse-kind op) - ((:argument :result) - (let ((temp (operand-parse-temp op)) - (name (operand-parse-name op))) - (cond ((and (operand-parse-load op) (operand-parse-scs op)) - (binds `(,(operand-parse-load-tn op) - (tn-ref-load-tn ,temp))) - (binds `(,name ,(decide-to-load parse op))) - (if (eq (operand-parse-kind op) :argument) - (loads (call-move-fun parse op t)) - (saves (call-move-fun parse op nil)))) - (t - (binds `(,name (tn-ref-tn ,temp))))))) - (:temporary - (binds `(,(operand-parse-name op) - (tn-ref-tn ,(operand-parse-temp op))))) - ((:more-argument :more-result)))) + (ecase (operand-parse-kind op) + ((:argument :result) + (let ((temp (operand-parse-temp op)) + (name (operand-parse-name op))) + (cond ((and (operand-parse-load op) (operand-parse-scs op)) + (binds `(,(operand-parse-load-tn op) + (tn-ref-load-tn ,temp))) + (binds `(,name ,(decide-to-load parse op))) + (if (eq (operand-parse-kind op) :argument) + (loads (call-move-fun parse op t)) + (saves (call-move-fun parse op nil)))) + (t + (binds `(,name (tn-ref-tn ,temp))))))) + (:temporary + (binds `(,(operand-parse-name op) + (tn-ref-tn ,(operand-parse-temp op))))) + ((:more-argument :more-result)))) `(lambda (,n-vop) - (let* (,@(access-operands (vop-parse-args parse) - (vop-parse-more-args parse) - `(vop-args ,n-vop)) - ,@(access-operands (vop-parse-results parse) - (vop-parse-more-results parse) - `(vop-results ,n-vop)) - ,@(access-operands (vop-parse-temps parse) nil - `(vop-temps ,n-vop)) - ,@(when (vop-parse-info-args parse) - `((,n-info (vop-codegen-info ,n-vop)) - ,@(mapcar (lambda (x) `(,x (pop ,n-info))) - (vop-parse-info-args parse)))) - ,@(when (vop-parse-variant-vars parse) - `((,n-variant (vop-info-variant (vop-info ,n-vop))) - ,@(mapcar (lambda (x) `(,x (pop ,n-variant))) - (vop-parse-variant-vars parse)))) - ,@(when (vop-parse-node-var parse) - `((,(vop-parse-node-var parse) (vop-node ,n-vop)))) - ,@(binds)) - (declare (ignore ,@(vop-parse-ignores parse))) - ,@(loads) - (sb!assem:assemble (*code-segment* ,n-vop) - ,@(vop-parse-body parse)) - ,@(saves)))))) + (let* (,@(access-operands (vop-parse-args parse) + (vop-parse-more-args parse) + `(vop-args ,n-vop)) + ,@(access-operands (vop-parse-results parse) + (vop-parse-more-results parse) + `(vop-results ,n-vop)) + ,@(access-operands (vop-parse-temps parse) nil + `(vop-temps ,n-vop)) + ,@(when (vop-parse-info-args parse) + `((,n-info (vop-codegen-info ,n-vop)) + ,@(mapcar (lambda (x) `(,x (pop ,n-info))) + (vop-parse-info-args parse)))) + ,@(when (vop-parse-variant-vars parse) + `((,n-variant (vop-info-variant (vop-info ,n-vop))) + ,@(mapcar (lambda (x) `(,x (pop ,n-variant))) + (vop-parse-variant-vars parse)))) + ,@(when (vop-parse-node-var parse) + `((,(vop-parse-node-var parse) (vop-node ,n-vop)))) + ,@(binds)) + (declare (ignore ,@(vop-parse-ignores parse))) + ,@(loads) + (sb!assem:assemble (*code-segment* ,n-vop) + ,@(vop-parse-body parse)) + ,@(saves)))))) +(defvar *parse-vop-operand-count*) +(defun make-operand-parse-temp () + (without-package-locks + (intern (format nil "OPERAND-PARSE-TEMP-~D" *parse-vop-operand-count*) + (symbol-package '*parse-vop-operand-count*)))) +(defun make-operand-parse-load-tn () + (without-package-locks + (intern (format nil "OPERAND-PARSE-LOAD-TN-~D" *parse-vop-operand-count*) + (symbol-package '*parse-vop-operand-count*)))) + ;;; Given a list of operand specifications as given to DEFINE-VOP, ;;; return a list of OPERAND-PARSE structures describing the fixed ;;; operands, and a single OPERAND-PARSE describing any more operand. @@ -891,91 +891,92 @@ ;;; operand of the same name. (defun !parse-vop-operands (parse specs kind) (declare (list specs) - (type (member :argument :result) kind)) + (type (member :argument :result) kind)) (let ((num -1) - (more nil)) + (more nil)) (collect ((operands)) (dolist (spec specs) - (unless (and (consp spec) (symbolp (first spec)) (oddp (length spec))) - (error "malformed operand specifier: ~S" spec)) - (when more - (error "The MORE operand isn't the last operand: ~S" specs)) - (let* ((name (first spec)) - (old (if (vop-parse-inherits parse) - (find-operand name - (vop-parse-or-lose - (vop-parse-inherits parse)) - (list kind) - nil) - nil)) - (res (if old - (make-operand-parse - :name name - :kind kind - :target (operand-parse-target old) - :born (operand-parse-born old) - :dies (operand-parse-dies old) - :scs (operand-parse-scs old) - :load-tn (operand-parse-load-tn old) - :load (operand-parse-load old)) - (ecase kind - (:argument - (make-operand-parse - :name (first spec) - :kind :argument - :born (parse-time-spec :load) - :dies (parse-time-spec `(:argument ,(incf num))))) - (:result - (make-operand-parse - :name (first spec) - :kind :result - :born (parse-time-spec `(:result ,(incf num))) - :dies (parse-time-spec :save))))))) - (do ((key (rest spec) (cddr key))) - ((null key)) - (let ((value (second key))) - (case (first key) - (:scs - (aver (typep value 'list)) - (setf (operand-parse-scs res) (remove-duplicates value))) - (:load-tn - (aver (typep value 'symbol)) - (setf (operand-parse-load-tn res) value)) - (:load-if - (setf (operand-parse-load res) value)) - (:more - (aver (typep value 'boolean)) - (setf (operand-parse-kind res) - (if (eq kind :argument) :more-argument :more-result)) - (setf (operand-parse-load res) nil) - (setq more res)) - (:target - (aver (typep value 'symbol)) - (setf (operand-parse-target res) value)) - (:from - (unless (eq kind :result) - (error "can only specify :FROM in a result: ~S" spec)) - (setf (operand-parse-born res) (parse-time-spec value))) - (:to - (unless (eq kind :argument) - (error "can only specify :TO in an argument: ~S" spec)) - (setf (operand-parse-dies res) (parse-time-spec value))) - (t - (error "unknown keyword in operand specifier: ~S" spec))))) - - (cond ((not more) - (operands res)) - ((operand-parse-target more) - (error "cannot specify :TARGET in a :MORE operand")) - ((operand-parse-load more) - (error "cannot specify :LOAD-IF in a :MORE operand"))))) + (unless (and (consp spec) (symbolp (first spec)) (oddp (length spec))) + (error "malformed operand specifier: ~S" spec)) + (when more + (error "The MORE operand isn't the last operand: ~S" specs)) + (incf *parse-vop-operand-count*) + (let* ((name (first spec)) + (old (if (vop-parse-inherits parse) + (find-operand name + (vop-parse-or-lose + (vop-parse-inherits parse)) + (list kind) + nil) + nil)) + (res (if old + (make-operand-parse + :name name + :kind kind + :target (operand-parse-target old) + :born (operand-parse-born old) + :dies (operand-parse-dies old) + :scs (operand-parse-scs old) + :load-tn (operand-parse-load-tn old) + :load (operand-parse-load old)) + (ecase kind + (:argument + (make-operand-parse + :name (first spec) + :kind :argument + :born (parse-time-spec :load) + :dies (parse-time-spec `(:argument ,(incf num))))) + (:result + (make-operand-parse + :name (first spec) + :kind :result + :born (parse-time-spec `(:result ,(incf num))) + :dies (parse-time-spec :save))))))) + (do ((key (rest spec) (cddr key))) + ((null key)) + (let ((value (second key))) + (case (first key) + (:scs + (aver (typep value 'list)) + (setf (operand-parse-scs res) (remove-duplicates value))) + (:load-tn + (aver (typep value 'symbol)) + (setf (operand-parse-load-tn res) value)) + (:load-if + (setf (operand-parse-load res) value)) + (:more + (aver (typep value 'boolean)) + (setf (operand-parse-kind res) + (if (eq kind :argument) :more-argument :more-result)) + (setf (operand-parse-load res) nil) + (setq more res)) + (:target + (aver (typep value 'symbol)) + (setf (operand-parse-target res) value)) + (:from + (unless (eq kind :result) + (error "can only specify :FROM in a result: ~S" spec)) + (setf (operand-parse-born res) (parse-time-spec value))) + (:to + (unless (eq kind :argument) + (error "can only specify :TO in an argument: ~S" spec)) + (setf (operand-parse-dies res) (parse-time-spec value))) + (t + (error "unknown keyword in operand specifier: ~S" spec))))) + + (cond ((not more) + (operands res)) + ((operand-parse-target more) + (error "cannot specify :TARGET in a :MORE operand")) + ((operand-parse-load more) + (error "cannot specify :LOAD-IF in a :MORE operand"))))) (values (the list (operands)) more)))) ;;; Parse a temporary specification, putting the OPERAND-PARSE ;;; structures in the PARSE structure. (defun parse-temporary (spec parse) (declare (list spec) - (type vop-parse parse)) + (type vop-parse parse)) (let ((len (length spec))) (unless (>= len 2) (error "malformed temporary spec: ~S" spec)) @@ -987,135 +988,150 @@ (warn "temporary spec allocates no temps:~% ~S" spec)) (dolist (name (cddr spec)) (unless (symbolp name) - (error "bad temporary name: ~S" name)) + (error "bad temporary name: ~S" name)) + (incf *parse-vop-operand-count*) (let ((res (make-operand-parse :name name - :kind :temporary - :temp-temp (gensym) - :born (parse-time-spec :load) - :dies (parse-time-spec :save)))) - (do ((opt (second spec) (cddr opt))) - ((null opt)) - (case (first opt) - (:target - (setf (operand-parse-target res) - (vop-spec-arg opt 'symbol 1 nil))) - (:sc - (setf (operand-parse-sc res) - (vop-spec-arg opt 'symbol 1 nil))) - (:offset - (let ((offset (eval (second opt)))) - (aver (typep offset 'unsigned-byte)) - (setf (operand-parse-offset res) offset))) - (:from - (setf (operand-parse-born res) (parse-time-spec (second opt)))) - (:to - (setf (operand-parse-dies res) (parse-time-spec (second opt)))) - ;; backward compatibility... - (:scs - (let ((scs (vop-spec-arg opt 'list 1 nil))) - (unless (= (length scs) 1) - (error "must specify exactly one SC for a temporary")) - (setf (operand-parse-sc res) (first scs)))) - (:type) - (t - (error "unknown temporary option: ~S" opt)))) - - (unless (and (time-spec-order (operand-parse-dies res) - (operand-parse-born res)) - (not (time-spec-order (operand-parse-born res) - (operand-parse-dies res)))) - (error "Temporary lifetime doesn't begin before it ends: ~S" spec)) - - (unless (operand-parse-sc res) - (error "must specify :SC for all temporaries: ~S" spec)) - - (setf (vop-parse-temps parse) - (cons res - (remove name (vop-parse-temps parse) - :key #'operand-parse-name)))))) + :kind :temporary + :born (parse-time-spec :load) + :dies (parse-time-spec :save)))) + (do ((opt (second spec) (cddr opt))) + ((null opt)) + (case (first opt) + (:target + (setf (operand-parse-target res) + (vop-spec-arg opt 'symbol 1 nil))) + (:sc + (setf (operand-parse-sc res) + (vop-spec-arg opt 'symbol 1 nil))) + (:offset + (let ((offset (eval (second opt)))) + (aver (typep offset 'unsigned-byte)) + (setf (operand-parse-offset res) offset))) + (:from + (setf (operand-parse-born res) (parse-time-spec (second opt)))) + (:to + (setf (operand-parse-dies res) (parse-time-spec (second opt)))) + ;; backward compatibility... + (:scs + (let ((scs (vop-spec-arg opt 'list 1 nil))) + (unless (= (length scs) 1) + (error "must specify exactly one SC for a temporary")) + (setf (operand-parse-sc res) (first scs)))) + (:type) + (t + (error "unknown temporary option: ~S" opt)))) + + (unless (and (time-spec-order (operand-parse-dies res) + (operand-parse-born res)) + (not (time-spec-order (operand-parse-born res) + (operand-parse-dies res)))) + (error "Temporary lifetime doesn't begin before it ends: ~S" spec)) + + (unless (operand-parse-sc res) + (error "must specify :SC for all temporaries: ~S" spec)) + + (setf (vop-parse-temps parse) + (cons res + (remove name (vop-parse-temps parse) + :key #'operand-parse-name)))))) (values)) +(defun compute-parse-vop-operand-count (parse) + (declare (type vop-parse parse)) + (labels ((compute-count-aux (parse) + (declare (type vop-parse parse)) + (if (null (vop-parse-inherits parse)) + (length (vop-parse-operands parse)) + (+ (length (vop-parse-operands parse)) + (compute-count-aux + (vop-parse-or-lose (vop-parse-inherits parse))))))) + (if (null (vop-parse-inherits parse)) + 0 + (compute-count-aux (vop-parse-or-lose (vop-parse-inherits parse)))))) + ;;; the top level parse function: clobber PARSE to represent the ;;; specified options. (defun parse-define-vop (parse specs) (declare (type vop-parse parse) (list specs)) - (dolist (spec specs) - (unless (consp spec) - (error "malformed option specification: ~S" spec)) - (case (first spec) - (:args - (multiple-value-bind (fixed more) - (!parse-vop-operands parse (rest spec) :argument) - (setf (vop-parse-args parse) fixed) - (setf (vop-parse-more-args parse) more))) - (:results - (multiple-value-bind (fixed more) - (!parse-vop-operands parse (rest spec) :result) - (setf (vop-parse-results parse) fixed) - (setf (vop-parse-more-results parse) more)) - (setf (vop-parse-conditional-p parse) nil)) - (:conditional - (setf (vop-parse-result-types parse) ()) - (setf (vop-parse-results parse) ()) - (setf (vop-parse-more-results parse) nil) - (setf (vop-parse-conditional-p parse) t)) - (:temporary - (parse-temporary spec parse)) - (:generator - (setf (vop-parse-cost parse) - (vop-spec-arg spec 'unsigned-byte 1 nil)) - (setf (vop-parse-body parse) (cddr spec))) - (:effects - (setf (vop-parse-effects parse) (rest spec))) - (:affected - (setf (vop-parse-affected parse) (rest spec))) - (:info - (setf (vop-parse-info-args parse) (rest spec))) - (:ignore - (setf (vop-parse-ignores parse) (rest spec))) - (:variant - (setf (vop-parse-variant parse) (rest spec))) - (:variant-vars - (let ((vars (rest spec))) - (setf (vop-parse-variant-vars parse) vars) - (setf (vop-parse-variant parse) - (make-list (length vars) :initial-element nil)))) - (:variant-cost - (setf (vop-parse-cost parse) (vop-spec-arg spec 'unsigned-byte))) - (:vop-var - (setf (vop-parse-vop-var parse) (vop-spec-arg spec 'symbol))) - (:move-args - (setf (vop-parse-move-args parse) - (vop-spec-arg spec '(member nil :local-call :full-call - :known-return)))) - (:node-var - (setf (vop-parse-node-var parse) (vop-spec-arg spec 'symbol))) - (:note - (setf (vop-parse-note parse) (vop-spec-arg spec '(or string null)))) - (:arg-types - (setf (vop-parse-arg-types parse) - (!parse-vop-operand-types (rest spec) t))) - (:result-types - (setf (vop-parse-result-types parse) - (!parse-vop-operand-types (rest spec) nil))) - (:translate - (setf (vop-parse-translate parse) (rest spec))) - (:guard - (setf (vop-parse-guard parse) (vop-spec-arg spec t))) - ;; FIXME: :LTN-POLICY would be a better name for this. It would - ;; probably be good to leave it unchanged for a while, though, - ;; at least until the first port to some other architecture, - ;; since the renaming would be a change to the interface between - (:policy - (setf (vop-parse-ltn-policy parse) - (vop-spec-arg spec 'ltn-policy))) - (:save-p - (setf (vop-parse-save-p parse) - (vop-spec-arg spec - '(member t nil :compute-only :force-to-stack)))) - (t - (error "unknown option specifier: ~S" (first spec))))) - (values)) + (let ((*parse-vop-operand-count* (compute-parse-vop-operand-count parse))) + (dolist (spec specs) + (unless (consp spec) + (error "malformed option specification: ~S" spec)) + (case (first spec) + (:args + (multiple-value-bind (fixed more) + (!parse-vop-operands parse (rest spec) :argument) + (setf (vop-parse-args parse) fixed) + (setf (vop-parse-more-args parse) more))) + (:results + (multiple-value-bind (fixed more) + (!parse-vop-operands parse (rest spec) :result) + (setf (vop-parse-results parse) fixed) + (setf (vop-parse-more-results parse) more)) + (setf (vop-parse-conditional-p parse) nil)) + (:conditional + (setf (vop-parse-result-types parse) ()) + (setf (vop-parse-results parse) ()) + (setf (vop-parse-more-results parse) nil) + (setf (vop-parse-conditional-p parse) (or (rest spec) t))) + (:temporary + (parse-temporary spec parse)) + (:generator + (setf (vop-parse-cost parse) + (vop-spec-arg spec 'unsigned-byte 1 nil)) + (setf (vop-parse-body parse) (cddr spec))) + (:effects + (setf (vop-parse-effects parse) (rest spec))) + (:affected + (setf (vop-parse-affected parse) (rest spec))) + (:info + (setf (vop-parse-info-args parse) (rest spec))) + (:ignore + (setf (vop-parse-ignores parse) (rest spec))) + (:variant + (setf (vop-parse-variant parse) (rest spec))) + (:variant-vars + (let ((vars (rest spec))) + (setf (vop-parse-variant-vars parse) vars) + (setf (vop-parse-variant parse) + (make-list (length vars) :initial-element nil)))) + (:variant-cost + (setf (vop-parse-cost parse) (vop-spec-arg spec 'unsigned-byte))) + (:vop-var + (setf (vop-parse-vop-var parse) (vop-spec-arg spec 'symbol))) + (:move-args + (setf (vop-parse-move-args parse) + (vop-spec-arg spec '(member nil :local-call :full-call + :known-return)))) + (:node-var + (setf (vop-parse-node-var parse) (vop-spec-arg spec 'symbol))) + (:note + (setf (vop-parse-note parse) (vop-spec-arg spec '(or string null)))) + (:arg-types + (setf (vop-parse-arg-types parse) + (!parse-vop-operand-types (rest spec) t))) + (:result-types + (setf (vop-parse-result-types parse) + (!parse-vop-operand-types (rest spec) nil))) + (:translate + (setf (vop-parse-translate parse) (rest spec))) + (:guard + (setf (vop-parse-guard parse) (vop-spec-arg spec t))) + ;; FIXME: :LTN-POLICY would be a better name for this. It + ;; would probably be good to leave it unchanged for a while, + ;; though, at least until the first port to some other + ;; architecture, since the renaming would be a change to the + ;; interface between + (:policy + (setf (vop-parse-ltn-policy parse) + (vop-spec-arg spec 'ltn-policy))) + (:save-p + (setf (vop-parse-save-p parse) + (vop-spec-arg spec + '(member t nil :compute-only :force-to-stack)))) + (t + (error "unknown option specifier: ~S" (first spec))))) + (values))) ;;;; making costs and restrictions @@ -1130,42 +1146,42 @@ (defun compute-loading-costs (op load-p) (declare (type operand-parse op)) (let ((scs (operand-parse-scs op)) - (costs (make-array sc-number-limit :initial-element nil)) - (load-scs (make-array sc-number-limit :initial-element nil))) + (costs (make-array sc-number-limit :initial-element nil)) + (load-scs (make-array sc-number-limit :initial-element nil))) (dolist (sc-name scs) (let* ((load-sc (meta-sc-or-lose sc-name)) - (load-scn (sc-number load-sc))) - (setf (svref costs load-scn) 0) - (setf (svref load-scs load-scn) t) - (dolist (op-sc (append (when load-p - (sc-constant-scs load-sc)) - (sc-alternate-scs load-sc))) - (let* ((op-scn (sc-number op-sc)) - (load (if load-p - (aref (sc-load-costs load-sc) op-scn) - (aref (sc-load-costs op-sc) load-scn)))) - (unless load - (error "no move function defined to move ~:[from~;to~] SC ~ - ~S~%~:[to~;from~] alternate or constant SC ~S" - load-p sc-name load-p (sc-name op-sc))) - - (let ((op-cost (svref costs op-scn))) - (when (or (not op-cost) (< load op-cost)) - (setf (svref costs op-scn) load))) - - (let ((op-load (svref load-scs op-scn))) - (unless (eq op-load t) - (pushnew load-scn (svref load-scs op-scn)))))) - - (dotimes (i sc-number-limit) - (unless (svref costs i) - (let ((op-sc (svref *backend-meta-sc-numbers* i))) - (when op-sc - (let ((cost (if load-p - (svref (sc-move-costs load-sc) i) - (svref (sc-move-costs op-sc) load-scn)))) - (when cost - (setf (svref costs i) cost))))))))) + (load-scn (sc-number load-sc))) + (setf (svref costs load-scn) 0) + (setf (svref load-scs load-scn) t) + (dolist (op-sc (append (when load-p + (sc-constant-scs load-sc)) + (sc-alternate-scs load-sc))) + (let* ((op-scn (sc-number op-sc)) + (load (if load-p + (aref (sc-load-costs load-sc) op-scn) + (aref (sc-load-costs op-sc) load-scn)))) + (unless load + (error "no move function defined to move ~:[from~;to~] SC ~ + ~S~%~:[to~;from~] alternate or constant SC ~S" + load-p sc-name load-p (sc-name op-sc))) + + (let ((op-cost (svref costs op-scn))) + (when (or (not op-cost) (< load op-cost)) + (setf (svref costs op-scn) load))) + + (let ((op-load (svref load-scs op-scn))) + (unless (eq op-load t) + (pushnew load-scn (svref load-scs op-scn)))))) + + (dotimes (i sc-number-limit) + (unless (svref costs i) + (let ((op-sc (svref *backend-meta-sc-numbers* i))) + (when op-sc + (let ((cost (if load-p + (svref (sc-move-costs load-sc) i) + (svref (sc-move-costs op-sc) load-scn)))) + (when cost + (setf (svref costs i) cost))))))))) (values costs load-scs))) @@ -1185,35 +1201,35 @@ (defun compute-costs-and-restrictions-list (ops load-p) (declare (list ops)) (collect ((costs) - (scs)) + (scs)) (dolist (op ops) (multiple-value-bind (costs scs) (compute-loading-costs-if-any op load-p) - (costs costs) - (scs scs))) + (costs costs) + (scs scs))) (values (costs) (scs)))) (defun make-costs-and-restrictions (parse) (multiple-value-bind (arg-costs arg-scs) (compute-costs-and-restrictions-list (vop-parse-args parse) t) (multiple-value-bind (result-costs result-scs) - (compute-costs-and-restrictions-list (vop-parse-results parse) nil) + (compute-costs-and-restrictions-list (vop-parse-results parse) nil) `( - :cost ,(vop-parse-cost parse) - - :arg-costs ',arg-costs - :arg-load-scs ',arg-scs - :result-costs ',result-costs - :result-load-scs ',result-scs - - :more-arg-costs - ',(if (vop-parse-more-args parse) - (compute-loading-costs-if-any (vop-parse-more-args parse) t) - nil) - - :more-result-costs - ',(if (vop-parse-more-results parse) - (compute-loading-costs-if-any (vop-parse-more-results parse) nil) - nil))))) + :cost ,(vop-parse-cost parse) + + :arg-costs ',arg-costs + :arg-load-scs ',arg-scs + :result-costs ',result-costs + :result-load-scs ',result-scs + + :more-arg-costs + ',(if (vop-parse-more-args parse) + (compute-loading-costs-if-any (vop-parse-more-args parse) t) + nil) + + :more-result-costs + ',(if (vop-parse-more-results parse) + (compute-loading-costs-if-any (vop-parse-more-results parse) nil) + nil))))) ;;;; operand checking and stuff @@ -1222,50 +1238,50 @@ (defun !parse-vop-operand-types (specs args-p) (declare (list specs)) (labels ((parse-operand-type (spec) - (cond ((eq spec '*) spec) - ((symbolp spec) - (let ((alias (gethash spec - *backend-primitive-type-aliases*))) - (if alias - (parse-operand-type alias) - `(:or ,spec)))) - ((atom spec) - (error "bad thing to be a operand type: ~S" spec)) - (t - (case (first spec) - (:or - (collect ((results)) - (results :or) - (dolist (item (cdr spec)) - (unless (symbolp item) - (error "bad PRIMITIVE-TYPE name in ~S: ~S" - spec item)) - (let ((alias - (gethash item - *backend-primitive-type-aliases*))) - (if alias - (let ((alias (parse-operand-type alias))) - (unless (eq (car alias) :or) - (error "can't include primitive-type ~ - alias ~S in an :OR restriction: ~S" - item spec)) - (dolist (x (cdr alias)) - (results x))) - (results item)))) - (remove-duplicates (results) - :test #'eq - :start 1))) - (:constant - (unless args-p - (error "can't :CONSTANT for a result")) - (unless (= (length spec) 2) - (error "bad :CONSTANT argument type spec: ~S" spec)) - spec) - (t - (error "bad thing to be a operand type: ~S" spec))))))) + (cond ((eq spec '*) spec) + ((symbolp spec) + (let ((alias (gethash spec + *backend-primitive-type-aliases*))) + (if alias + (parse-operand-type alias) + `(:or ,spec)))) + ((atom spec) + (error "bad thing to be a operand type: ~S" spec)) + (t + (case (first spec) + (:or + (collect ((results)) + (results :or) + (dolist (item (cdr spec)) + (unless (symbolp item) + (error "bad PRIMITIVE-TYPE name in ~S: ~S" + spec item)) + (let ((alias + (gethash item + *backend-primitive-type-aliases*))) + (if alias + (let ((alias (parse-operand-type alias))) + (unless (eq (car alias) :or) + (error "can't include primitive-type ~ + alias ~S in an :OR restriction: ~S" + item spec)) + (dolist (x (cdr alias)) + (results x))) + (results item)))) + (remove-duplicates (results) + :test #'eq + :start 1))) + (:constant + (unless args-p + (error "can't :CONSTANT for a result")) + (unless (= (length spec) 2) + (error "bad :CONSTANT argument type spec: ~S" spec)) + spec) + (t + (error "bad thing to be a operand type: ~S" spec))))))) (mapcar #'parse-operand-type specs))) -;;; Check the consistency of Op's Sc restrictions with the specified +;;; Check the consistency of OP's SC restrictions with the specified ;;; primitive-type restriction. :CONSTANT operands have already been ;;; filtered out, so only :OR and * restrictions are left. ;;; @@ -1276,36 +1292,36 @@ (defun check-operand-type-scs (parse op type load-p) (declare (type vop-parse parse) (type operand-parse op)) (let ((ptypes (if (eq type '*) (list t) (rest type))) - (scs (operand-parse-scs op))) + (scs (operand-parse-scs op))) (when scs (multiple-value-bind (costs load-scs) (compute-loading-costs op load-p) - (declare (ignore costs)) - (dolist (ptype ptypes) - (unless (dolist (rep (primitive-type-scs - (meta-primitive-type-or-lose ptype)) - nil) - (when (svref load-scs rep) (return t))) - (error "In the ~A ~:[result~;argument~] to VOP ~S,~@ - none of the SCs allowed by the operand type ~S can ~ - directly be loaded~@ - into any of the restriction's SCs:~% ~S~:[~;~@ - [* type operand must allow T's SCs.]~]" - (operand-parse-name op) load-p (vop-parse-name parse) - ptype - scs (eq type '*))))) + (declare (ignore costs)) + (dolist (ptype ptypes) + (unless (dolist (rep (primitive-type-scs + (meta-primitive-type-or-lose ptype)) + nil) + (when (svref load-scs rep) (return t))) + (error "In the ~A ~:[result~;argument~] to VOP ~S,~@ + none of the SCs allowed by the operand type ~S can ~ + directly be loaded~@ + into any of the restriction's SCs:~% ~S~:[~;~@ + [* type operand must allow T's SCs.]~]" + (operand-parse-name op) load-p (vop-parse-name parse) + ptype + scs (eq type '*))))) (dolist (sc scs) - (unless (or (eq type '*) - (dolist (ptype ptypes nil) - (when (meta-sc-allowed-by-primitive-type - (meta-sc-or-lose sc) - (meta-primitive-type-or-lose ptype)) - (return t)))) - (warn "~:[Result~;Argument~] ~A to VOP ~S~@ - has SC restriction ~S which is ~ - not allowed by the operand type:~% ~S" - load-p (operand-parse-name op) (vop-parse-name parse) - sc type))))) + (unless (or (eq type '*) + (dolist (ptype ptypes nil) + (when (meta-sc-allowed-by-primitive-type + (meta-sc-or-lose sc) + (meta-primitive-type-or-lose ptype)) + (return t)))) + (warn "~:[Result~;Argument~] ~A to VOP ~S~@ + has SC restriction ~S which is ~ + not allowed by the operand type:~% ~S" + load-p (operand-parse-name op) (vop-parse-name parse) + sc type))))) (values)) @@ -1313,32 +1329,32 @@ ;;; against the number of defined operands. (defun check-operand-types (parse ops more-op types load-p) (declare (type vop-parse parse) (list ops) - (type (or list (member :unspecified)) types) - (type (or operand-parse null) more-op)) + (type (or list (member :unspecified)) types) + (type (or operand-parse null) more-op)) (unless (eq types :unspecified) (let ((num (+ (length ops) (if more-op 1 0)))) (unless (= (count-if-not (lambda (x) - (and (consp x) - (eq (car x) :constant))) - types) - num) - (error "expected ~W ~:[result~;argument~] type~P: ~S" - num load-p types num))) + (and (consp x) + (eq (car x) :constant))) + types) + num) + (error "expected ~W ~:[result~;argument~] type~P: ~S" + num load-p types num))) (when more-op (let ((mtype (car (last types)))) - (when (and (consp mtype) (eq (first mtype) :constant)) - (error "can't use :CONSTANT on VOP more args"))))) + (when (and (consp mtype) (eq (first mtype) :constant)) + (error "can't use :CONSTANT on VOP more args"))))) (when (vop-parse-translate parse) (let ((types (specify-operand-types types ops more-op))) (mapc (lambda (x y) - (check-operand-type-scs parse x y load-p)) - (if more-op (butlast ops) ops) - (remove-if (lambda (x) - (and (consp x) - (eq (car x) ':constant))) - (if more-op (butlast types) types))))) + (check-operand-type-scs parse x y load-p)) + (if more-op (butlast ops) ops) + (remove-if (lambda (x) + (and (consp x) + (eq (car x) ':constant))) + (if more-op (butlast types) types))))) (values)) @@ -1348,25 +1364,25 @@ (declare (type vop-parse parse)) (setf (vop-parse-operands parse) - (append (vop-parse-args parse) - (if (vop-parse-more-args parse) - (list (vop-parse-more-args parse))) - (vop-parse-results parse) - (if (vop-parse-more-results parse) - (list (vop-parse-more-results parse))) - (vop-parse-temps parse))) + (append (vop-parse-args parse) + (if (vop-parse-more-args parse) + (list (vop-parse-more-args parse))) + (vop-parse-results parse) + (if (vop-parse-more-results parse) + (list (vop-parse-more-results parse))) + (vop-parse-temps parse))) (check-operand-types parse - (vop-parse-args parse) - (vop-parse-more-args parse) - (vop-parse-arg-types parse) - t) + (vop-parse-args parse) + (vop-parse-more-args parse) + (vop-parse-arg-types parse) + t) (check-operand-types parse - (vop-parse-results parse) - (vop-parse-more-results parse) - (vop-parse-result-types parse) - nil) + (vop-parse-results parse) + (vop-parse-more-results parse) + (vop-parse-result-types parse) + nil) (values)) @@ -1380,32 +1396,36 @@ (defun !set-up-fun-translation (parse n-template) (declare (type vop-parse parse)) (mapcar (lambda (name) - `(let ((info (fun-info-or-lose ',name))) - (setf (fun-info-templates info) - (adjoin-template ,n-template (fun-info-templates info))) - ,@(when (vop-parse-conditional-p parse) - '((setf (fun-info-attributes info) - (attributes-union - (ir1-attributes predicate) - (fun-info-attributes info))))))) - (vop-parse-translate parse))) + `(let ((info (fun-info-or-lose ',name))) + (setf (fun-info-templates info) + (adjoin-template ,n-template (fun-info-templates info))) + ,@(when (vop-parse-conditional-p parse) + '((setf (fun-info-attributes info) + (attributes-union + (ir1-attributes predicate) + (fun-info-attributes info))))))) + (vop-parse-translate parse))) ;;; Return a form that can be evaluated to get the TEMPLATE operand type ;;; restriction from the given specification. (defun make-operand-type (type) (cond ((eq type '*) ''*) - ((symbolp type) - ``(:or ,(primitive-type-or-lose ',type))) - (t - (ecase (first type) - (:or - ``(:or ,,@(mapcar (lambda (type) - `(primitive-type-or-lose ',type)) - (rest type)))) - (:constant - ``(:constant ,#'(lambda (x) - (typep x ',(second type))) - ,',(second type))))))) + ((symbolp type) + ``(:or ,(primitive-type-or-lose ',type))) + (t + (ecase (car type) + (:or + ``(:or ,,@(mapcar (lambda (type) + `(primitive-type-or-lose ',type)) + (rest type)))) + (:constant + ``(:constant ,#'(lambda (x) + ;; Can't handle SATISFIES during XC + ,(if (and (consp (second type)) + (eq (caadr type) 'satisfies)) + `(,(cadadr type) x) + `(sb!xc:typep x ',(second type)))) + ,',(second type))))))) (defun specify-operand-types (types ops more-ops) (if (eq types :unspecified) @@ -1418,27 +1438,30 @@ ;;; type until the template has been made. (defun make-vop-info-types (parse) (let* ((more-args (vop-parse-more-args parse)) - (all-args (specify-operand-types (vop-parse-arg-types parse) - (vop-parse-args parse) - more-args)) - (args (if more-args (butlast all-args) all-args)) - (more-arg (when more-args (car (last all-args)))) - (more-results (vop-parse-more-results parse)) - (all-results (specify-operand-types (vop-parse-result-types parse) - (vop-parse-results parse) - more-results)) - (results (if more-results (butlast all-results) all-results)) - (more-result (when more-results (car (last all-results)))) - (conditional (vop-parse-conditional-p parse))) + (all-args (specify-operand-types (vop-parse-arg-types parse) + (vop-parse-args parse) + more-args)) + (args (if more-args (butlast all-args) all-args)) + (more-arg (when more-args (car (last all-args)))) + (more-results (vop-parse-more-results parse)) + (all-results (specify-operand-types (vop-parse-result-types parse) + (vop-parse-results parse) + more-results)) + (results (if more-results (butlast all-results) all-results)) + (more-result (when more-results (car (last all-results)))) + (conditional (vop-parse-conditional-p parse))) `(:type (specifier-type '(function () nil)) :arg-types (list ,@(mapcar #'make-operand-type args)) :more-args-type ,(when more-args (make-operand-type more-arg)) - :result-types ,(if conditional - :conditional - `(list ,@(mapcar #'make-operand-type results))) + :result-types ,(cond ((eq conditional t) + :conditional) + (conditional + `'(:conditional . ,conditional)) + (t + `(list ,@(mapcar #'make-operand-type results)))) :more-results-type ,(when more-results - (make-operand-type more-result))))) + (make-operand-type more-result))))) ;;;; setting up VOP-INFO @@ -1457,30 +1480,30 @@ (defmacro inherit-vop-info (slot parse test form) `(if (and ,parse ,test) (list ,slot `(,',(or (cdr (assoc slot *slot-inherit-alist*)) - (error "unknown slot ~S" slot)) - (template-or-lose ',(vop-parse-name ,parse)))) + (error "unknown slot ~S" slot)) + (template-or-lose ',(vop-parse-name ,parse)))) (list ,slot ,form))) ;;; Return a form that creates a VOP-INFO structure which describes VOP. (defun set-up-vop-info (iparse parse) (declare (type vop-parse parse) (type (or vop-parse null) iparse)) (let ((same-operands - (and iparse - (equal (vop-parse-operands parse) - (vop-parse-operands iparse)) - (equal (vop-parse-info-args iparse) - (vop-parse-info-args parse)))) - (variant (vop-parse-variant parse))) + (and iparse + (equal (vop-parse-operands parse) + (vop-parse-operands iparse)) + (equal (vop-parse-info-args iparse) + (vop-parse-info-args parse)))) + (variant (vop-parse-variant parse))) (let ((nvars (length (vop-parse-variant-vars parse)))) (unless (= (length variant) nvars) - (error "expected ~W variant values: ~S" nvars variant))) + (error "expected ~W variant values: ~S" nvars variant))) `(make-vop-info :name ',(vop-parse-name parse) ,@(make-vop-info-types parse) :guard ,(when (vop-parse-guard parse) - `(lambda () ,(vop-parse-guard parse))) + `(lambda () ,(vop-parse-guard parse))) :note ',(vop-parse-note parse) :info-arg-count ,(length (vop-parse-info-args parse)) :ltn-policy ',(vop-parse-ltn-policy parse) @@ -1491,10 +1514,10 @@ ,@(make-costs-and-restrictions parse) ,@(make-emit-function-and-friends parse) ,@(inherit-vop-info :generator-function iparse - (and same-operands - (equal (vop-parse-body parse) (vop-parse-body iparse))) - (unless (eq (vop-parse-body parse) :unspecified) - (make-generator-function parse))) + (and same-operands + (equal (vop-parse-body parse) (vop-parse-body iparse))) + (unless (eq (vop-parse-body parse) :unspecified) + (make-generator-function parse))) :variant (list ,@variant)))) ;;; Define the symbol NAME to be a Virtual OPeration in the compiler. @@ -1523,7 +1546,7 @@ ;;; :LOAD-IF EXPRESSION ;;; Controls whether automatic operand loading is done. ;;; EXPRESSION is evaluated with the fixed operand TNs bound. -;;; If EXPRESSION is true,then loading is done and the variable +;;; If EXPRESSION is true, then loading is done and the variable ;;; is bound to the load TN in the generator body. Otherwise, ;;; loading is not done, and the variable is bound to the actual ;;; operand. @@ -1546,7 +1569,7 @@ ;;; (:ARGUMENT N)/(:RESULT N). These options are necessary ;;; primarily when operands are read or written out of order. ;;; -;;; :CONDITIONAL +;;; :CONDITIONAL [Condition-descriptor+] ;;; This is used in place of :RESULTS with conditional branch VOPs. ;;; There are no result values: the result is a transfer of control. ;;; The target label is passed as the first :INFO arg. The second @@ -1554,6 +1577,10 @@ ;;; A side effect is to set the PREDICATE attribute for functions ;;; in the :TRANSLATE option. ;;; +;;; If some condition descriptors are provided, this is a flag-setting +;;; VOP. Descriptors are interpreted in an architecture-dependent +;;; manner. See the BRANCH-IF VOP in $ARCH/pred.lisp. +;;; ;;; :TEMPORARY ({Key Value}*) Name* ;;; Allocate a temporary TN for each Name, binding that variable to ;;; the TN within the body of the generators. In addition to :TARGET @@ -1564,7 +1591,7 @@ ;;; :OFFSET SB-Offset ;;; Force the temporary to be allocated in the specified SC ;;; with the specified offset. Offset is evaluated at -;;; macroexpand time. If Offset is emitted, the register +;;; macroexpand time. If Offset is omitted, the register ;;; allocator chooses a free location in SC. If both SC and ;;; Offset are omitted, then the temporary is packed according ;;; to its primitive type. @@ -1574,7 +1601,7 @@ ;;; Similar to the argument/result option, this specifies the ;;; start and end of the temporaries' lives. The defaults are ;;; :LOAD and :SAVE, i.e. the duration of the VOP. The other -;;; intervening phases are :ARGUMENT,:EVAL and :RESULT. +;;; 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). ;;; @@ -1615,7 +1642,7 @@ ;;; corresponding Things within the body of the generator. ;;; ;;; :VARIANT-COST Cost -;;; Specifies the cost of this VOP, overriding the cost of any +;;; Specifies the cost of this VOP, overriding the cost of any ;;; inherited generator. ;;; ;;; :NOTE {String | NIL} @@ -1656,18 +1683,18 @@ ;;; :MOVE-ARGS {NIL | :FULL-CALL | :LOCAL-CALL | :KNOWN-RETURN} ;;; Indicates if and how the more args should be moved into a ;;; different frame. -(def!macro define-vop ((name &optional inherits) &rest specs) +(def!macro define-vop ((name &optional inherits) &body specs) (declare (type symbol name)) ;; Parse the syntax into a VOP-PARSE structure, and then expand into ;; code that creates the appropriate VOP-INFO structure at load time. ;; We implement inheritance by copying the VOP-PARSE structure for ;; the inherited structure. (let* ((inherited-parse (when inherits - (vop-parse-or-lose inherits))) - (parse (if inherits - (copy-vop-parse inherited-parse) - (make-vop-parse))) - (n-res (gensym))) + (vop-parse-or-lose inherits))) + (parse (if inherits + (copy-vop-parse inherited-parse) + (make-vop-parse))) + (n-res (gensym))) (setf (vop-parse-name parse) name) (setf (vop-parse-inherits parse) inherits) @@ -1676,14 +1703,14 @@ `(progn (eval-when (:compile-toplevel :load-toplevel :execute) - (setf (gethash ',name *backend-parsed-vops*) - ',parse)) + (setf (gethash ',name *backend-parsed-vops*) + ',parse)) (let ((,n-res ,(set-up-vop-info inherited-parse parse))) - (setf (gethash ',name *backend-template-names*) ,n-res) - (setf (template-type ,n-res) - (specifier-type (template-type-specifier ,n-res))) - ,@(!set-up-fun-translation parse n-res)) + (setf (gethash ',name *backend-template-names*) ,n-res) + (setf (template-type ,n-res) + (specifier-type (template-type-specifier ,n-res))) + ,@(!set-up-fun-translation parse n-res)) ',name))) ;;;; emission macros @@ -1699,23 +1726,23 @@ ;;; then we don't bother to set the tail. (defun make-operand-list (fixed more write-p) (collect ((forms) - (binds)) + (binds)) (let ((n-head nil) - (n-prev nil)) + (n-prev nil)) (dolist (op fixed) - (let ((n-ref (gensym))) - (binds `(,n-ref (reference-tn ,op ,write-p))) - (if n-prev - (forms `(setf (tn-ref-across ,n-prev) ,n-ref)) - (setq n-head n-ref)) - (setq n-prev n-ref))) + (let ((n-ref (gensym))) + (binds `(,n-ref (reference-tn ,op ,write-p))) + (if n-prev + (forms `(setf (tn-ref-across ,n-prev) ,n-ref)) + (setq n-head n-ref)) + (setq n-prev n-ref))) (when more - (let ((n-more (gensym))) - (binds `(,n-more ,more)) - (if n-prev - (forms `(setf (tn-ref-across ,n-prev) ,n-more)) - (setq n-head n-more)))) + (let ((n-more (gensym))) + (binds `(,n-more ,more)) + (if n-prev + (forms `(setf (tn-ref-across ,n-prev) ,n-more)) + (setq n-head n-more)))) (values (forms) (binds) n-head)))) @@ -1724,16 +1751,8 @@ ;;; Call the emit function for TEMPLATE, linking the result in at the ;;; end of BLOCK. (defmacro emit-template (node block template args results &optional info) - (let ((n-first (gensym)) - (n-last (gensym))) - (once-only ((n-node node) - (n-block block) - (n-template template)) - `(multiple-value-bind (,n-first ,n-last) - (funcall (template-emit-function ,n-template) - ,n-node ,n-block ,n-template ,args ,results - ,@(when info `(,info))) - (insert-vop-sequence ,n-first ,n-last ,n-block nil))))) + `(emit-and-insert-vop ,node ,block ,template ,args ,results nil + ,@(when info `(,info)))) ;;; VOP Name Node Block Arg* Info* Result* ;;; @@ -1751,45 +1770,45 @@ ;;; following the arguments are used for codegen info. (defmacro vop (name node block &rest operands) (let* ((parse (vop-parse-or-lose name)) - (arg-count (length (vop-parse-args parse))) - (result-count (length (vop-parse-results parse))) - (info-count (length (vop-parse-info-args parse))) - (noperands (+ arg-count result-count info-count)) - (n-node (gensym)) - (n-block (gensym)) - (n-template (gensym))) + (arg-count (length (vop-parse-args parse))) + (result-count (length (vop-parse-results parse))) + (info-count (length (vop-parse-info-args parse))) + (noperands (+ arg-count result-count info-count)) + (n-node (gensym)) + (n-block (gensym)) + (n-template (gensym))) (when (or (vop-parse-more-args parse) (vop-parse-more-results parse)) (error "cannot use VOP with variable operand count templates")) (unless (= noperands (length operands)) (error "called with ~W operands, but was expecting ~W" - (length operands) noperands)) + (length operands) noperands)) (multiple-value-bind (acode abinds n-args) - (make-operand-list (subseq operands 0 arg-count) nil nil) + (make-operand-list (subseq operands 0 arg-count) nil nil) (multiple-value-bind (rcode rbinds n-results) - (make-operand-list (subseq operands (+ arg-count info-count)) nil t) - - (collect ((ibinds) - (ivars)) - (dolist (info (subseq operands arg-count (+ arg-count info-count))) - (let ((temp (gensym))) - (ibinds `(,temp ,info)) - (ivars temp))) - - `(let* ((,n-node ,node) - (,n-block ,block) - (,n-template (template-or-lose ',name)) - ,@abinds - ,@(ibinds) - ,@rbinds) - ,@acode - ,@rcode - (emit-template ,n-node ,n-block ,n-template ,n-args - ,n-results - ,@(when (ivars) - `((list ,@(ivars))))) - (values))))))) + (make-operand-list (subseq operands (+ arg-count info-count)) nil t) + + (collect ((ibinds) + (ivars)) + (dolist (info (subseq operands arg-count (+ arg-count info-count))) + (let ((temp (gensym))) + (ibinds `(,temp ,info)) + (ivars temp))) + + `(let* ((,n-node ,node) + (,n-block ,block) + (,n-template (template-or-lose ',name)) + ,@abinds + ,@(ibinds) + ,@rbinds) + ,@acode + ,@rcode + (emit-template ,n-node ,n-block ,n-template ,n-args + ,n-results + ,@(when (ivars) + `((list ,@(ivars))))) + (values))))))) ;;; VOP* Name Node Block (Arg* More-Args) (Result* More-Results) Info* ;;; @@ -1809,40 +1828,40 @@ (defmacro vop* (name node block args results &rest info) (declare (type cons args results)) (let* ((parse (vop-parse-or-lose name)) - (arg-count (length (vop-parse-args parse))) - (result-count (length (vop-parse-results parse))) - (info-count (length (vop-parse-info-args parse))) - (fixed-args (butlast args)) - (fixed-results (butlast results)) - (n-node (gensym)) - (n-block (gensym)) - (n-template (gensym))) + (arg-count (length (vop-parse-args parse))) + (result-count (length (vop-parse-results parse))) + (info-count (length (vop-parse-info-args parse))) + (fixed-args (butlast args)) + (fixed-results (butlast results)) + (n-node (gensym)) + (n-block (gensym)) + (n-template (gensym))) (unless (or (vop-parse-more-args parse) - (<= (length fixed-args) arg-count)) + (<= (length fixed-args) arg-count)) (error "too many fixed arguments")) (unless (or (vop-parse-more-results parse) - (<= (length fixed-results) result-count)) + (<= (length fixed-results) result-count)) (error "too many fixed results")) (unless (= (length info) info-count) (error "expected ~W info args" info-count)) (multiple-value-bind (acode abinds n-args) - (make-operand-list fixed-args (car (last args)) nil) + (make-operand-list fixed-args (car (last args)) nil) (multiple-value-bind (rcode rbinds n-results) - (make-operand-list fixed-results (car (last results)) t) - - `(let* ((,n-node ,node) - (,n-block ,block) - (,n-template (template-or-lose ',name)) - ,@abinds - ,@rbinds) - ,@acode - ,@rcode - (emit-template ,n-node ,n-block ,n-template ,n-args ,n-results - ,@(when info - `((list ,@info)))) - (values)))))) + (make-operand-list fixed-results (car (last results)) t) + + `(let* ((,n-node ,node) + (,n-block ,block) + (,n-template (template-or-lose ',name)) + ,@abinds + ,@rbinds) + ,@acode + ,@rcode + (emit-template ,n-node ,n-block ,n-template ,n-args ,n-results + ,@(when info + `((list ,@info)))) + (values)))))) ;;;; miscellaneous macros @@ -1853,45 +1872,45 @@ ;;; beginning with T specifies a default. If it appears, it must be ;;; last. If no default is specified, and no clause matches, then an ;;; error is signalled. -(def!macro sc-case (tn &rest forms) +(def!macro sc-case (tn &body forms) (let ((n-sc (gensym)) - (n-tn (gensym))) + (n-tn (gensym))) (collect ((clauses)) (do ((cases forms (rest cases))) - ((null cases) - (clauses `(t (error "unknown SC to SC-CASE for ~S:~% ~S" ,n-tn - (sc-name (tn-sc ,n-tn)))))) - (let ((case (first cases))) - (when (atom case) - (error "illegal SC-CASE clause: ~S" case)) - (let ((head (first case))) - (when (eq head t) - (when (rest cases) - (error "T case is not last in SC-CASE.")) - (clauses `(t nil ,@(rest case))) - (return)) - (clauses `((or ,@(mapcar (lambda (x) - `(eql ,(meta-sc-number-or-lose x) - ,n-sc)) - (if (atom head) (list head) head))) - nil ,@(rest case)))))) + ((null cases) + (clauses `(t (error "unknown SC to SC-CASE for ~S:~% ~S" ,n-tn + (sc-name (tn-sc ,n-tn)))))) + (let ((case (first cases))) + (when (atom case) + (error "illegal SC-CASE clause: ~S" case)) + (let ((head (first case))) + (when (eq head t) + (when (rest cases) + (error "T case is not last in SC-CASE.")) + (clauses `(t nil ,@(rest case))) + (return)) + (clauses `((or ,@(mapcar (lambda (x) + `(eql ,(meta-sc-number-or-lose x) + ,n-sc)) + (if (atom head) (list head) head))) + nil ,@(rest case)))))) `(let* ((,n-tn ,tn) - (,n-sc (sc-number (tn-sc ,n-tn)))) - (cond ,@(clauses)))))) + (,n-sc (sc-number (tn-sc ,n-tn)))) + (cond ,@(clauses)))))) ;;; Return true if TNs SC is any of the named SCs, false otherwise. (defmacro sc-is (tn &rest scs) (once-only ((n-sc `(sc-number (tn-sc ,tn)))) `(or ,@(mapcar (lambda (x) - `(eql ,n-sc ,(meta-sc-number-or-lose x))) - scs)))) + `(eql ,n-sc ,(meta-sc-number-or-lose x))) + scs)))) ;;; Iterate over the IR2 blocks in component, in emission order. (defmacro do-ir2-blocks ((block-var component &optional result) - &body forms) + &body forms) `(do ((,block-var (block-info (component-head ,component)) - (ir2-block-next ,block-var))) + (ir2-block-next ,block-var))) ((null ,block-var) ,result) ,@forms)) @@ -1899,49 +1918,46 @@ ;;; represented by a local conflicts bit-vector and the IR2-BLOCK ;;; containing the location. (defmacro do-live-tns ((tn-var live block &optional result) &body body) - (let ((n-conf (gensym)) - (n-bod (gensym)) - (i (gensym)) - (ltns (gensym))) + (with-unique-names (conf bod i ltns) (once-only ((n-live live) - (n-block block)) + (n-block block)) `(block nil - (flet ((,n-bod (,tn-var) ,@body)) - ;; Do component-live TNs. - (dolist (,tn-var (ir2-component-component-tns - (component-info - (block-component - (ir2-block-block ,n-block))))) - (,n-bod ,tn-var)) - - (let ((,ltns (ir2-block-local-tns ,n-block))) - ;; Do TNs always-live in this block and live :MORE TNs. - (do ((,n-conf (ir2-block-global-tns ,n-block) - (global-conflicts-next-blockwise ,n-conf))) - ((null ,n-conf)) - (when (or (eq (global-conflicts-kind ,n-conf) :live) - (let ((,i (global-conflicts-number ,n-conf))) - (and (eq (svref ,ltns ,i) :more) - (not (zerop (sbit ,n-live ,i)))))) - (,n-bod (global-conflicts-tn ,n-conf)))) - ;; Do TNs locally live in the designated live set. - (dotimes (,i (ir2-block-local-tn-count ,n-block) ,result) - (unless (zerop (sbit ,n-live ,i)) - (let ((,tn-var (svref ,ltns ,i))) - (when (and ,tn-var (not (eq ,tn-var :more))) - (,n-bod ,tn-var))))))))))) + (flet ((,bod (,tn-var) ,@body)) + ;; Do component-live TNs. + (dolist (,tn-var (ir2-component-component-tns + (component-info + (block-component + (ir2-block-block ,n-block))))) + (,bod ,tn-var)) + + (let ((,ltns (ir2-block-local-tns ,n-block))) + ;; Do TNs always-live in this block and live :MORE TNs. + (do ((,conf (ir2-block-global-tns ,n-block) + (global-conflicts-next-blockwise ,conf))) + ((null ,conf)) + (when (or (eq (global-conflicts-kind ,conf) :live) + (let ((,i (global-conflicts-number ,conf))) + (and (eq (svref ,ltns ,i) :more) + (not (zerop (sbit ,n-live ,i)))))) + (,bod (global-conflicts-tn ,conf)))) + ;; Do TNs locally live in the designated live set. + (dotimes (,i (ir2-block-local-tn-count ,n-block) ,result) + (unless (zerop (sbit ,n-live ,i)) + (let ((,tn-var (svref ,ltns ,i))) + (when (and ,tn-var (not (eq ,tn-var :more))) + (,bod ,tn-var))))))))))) ;;; Iterate over all the IR2 blocks in PHYSENV, in emit order. (defmacro do-physenv-ir2-blocks ((block-var physenv &optional result) - &body body) + &body body) (once-only ((n-physenv physenv)) (once-only ((n-first `(lambda-block (physenv-lambda ,n-physenv)))) (once-only ((n-tail `(block-info - (component-tail - (block-component ,n-first))))) - `(do ((,block-var (block-info ,n-first) - (ir2-block-next ,block-var))) - ((or (eq ,block-var ,n-tail) - (not (eq (ir2-block-physenv ,block-var) ,n-physenv))) - ,result) - ,@body))))) + (component-tail + (block-component ,n-first))))) + `(do ((,block-var (block-info ,n-first) + (ir2-block-next ,block-var))) + ((or (eq ,block-var ,n-tail) + (not (eq (ir2-block-physenv ,block-var) ,n-physenv))) + ,result) + ,@body)))))