X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmeta-vmdef.lisp;h=aa732a61a650ee6dab59dbf01b1dbf27f25d6fc6;hb=9f71619d17025cc309fefaeac51107ffa8ed5ee4;hp=a948f99d46ca7e3f59213ce12f19440608bed4bd;hpb=5ec8d0c1c8b7939818b75118b472fac1af554f9a;p=sbcl.git diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp index a948f99..aa732a6 100644 --- a/src/compiler/meta-vmdef.lisp +++ b/src/compiler/meta-vmdef.lisp @@ -72,7 +72,10 @@ (/show0 "doing third SETF") (setf (finite-sb-live-tns res) (make-array ',size :initial-element nil)) - (/show0 "doing fourth and final SETF") + (/show0 "doing fourth SETF") + (setf (finite-sb-always-live-count res) + (make-array ',size :initial-element 0)) + (/show0 "doing fifth and final SETF") (setf (gethash ',name *backend-sb-names*) res))) @@ -83,38 +86,39 @@ (/show0 "finished with DEFINE-STORAGE-BASE expansion") ',name))) -;;; 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: +;;; Define a storage class NAME that uses the named Storage-Base. +;;; NUMBER is a small, non-negative integer that is used as an alias. +;;; The following keywords are defined: ;;; -;;; :Element-Size Size -;;; The size of objects in this SC in whatever units the SB uses. This -;;; defaults to 1. +;;; :ELEMENT-SIZE Size +;;; The size of objects in this SC in whatever units the SB uses. +;;; This defaults to 1. ;;; -;;; :Alignment Size -;;; The alignment restrictions for this SC. TNs will only be allocated at -;;; offsets that are an even multiple of this number. Defaults to 1. +;;; :ALIGNMENT Size +;;; The alignment restrictions for this SC. TNs will only be +;;; allocated at offsets that are an even multiple of this number. +;;; This defaults to 1. ;;; -;;; :Locations (Location*) -;;; If the SB is :Finite, then this is a list of the offsets within the SB -;;; that are in this SC. +;;; :LOCATIONS (Location*) +;;; If the SB is :FINITE, then this is a list of the offsets within +;;; the SB that are in this SC. ;;; -;;; :Reserve-Locations (Location*) +;;; :RESERVE-LOCATIONS (Location*) ;;; A subset of the Locations that the register allocator should try to ;;; reserve for operand loading (instead of to hold variable values.) ;;; -;;; :Save-P {T | NIL} +;;; :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. +;;; non-save-p :ALTERNATE-SCs across calls. ;;; -;;; :Alternate-SCs (SC*) +;;; :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\". There must be at least ;;; one SC in an unbounded SB, unless this SC is only used for restricted or ;;; wired TNs. ;;; -;;; :Constant-SCs (SC*) +;;; :CONSTANT-SCS (SC*) ;;; 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) @@ -126,7 +130,7 @@ (declare (type list locations reserve-locations alternate-scs constant-scs)) (declare (type boolean save-p)) (unless (= (logcount alignment) 1) - (error "alignment not a power of two: ~D" alignment)) + (error "alignment not a power of two: ~W" alignment)) (let ((sb (meta-sb-or-lose sb-name))) (if (eq (sb-kind sb) :finite) @@ -136,7 +140,7 @@ (dolist (el locations) (declare (type unsigned-byte el)) (unless (<= 1 (+ el element-size) size) - (error "SC element ~D out of bounds for ~S" el sb)))) + (error "SC element ~W out of bounds for ~S" el sb)))) (when locations (error ":LOCATIONS is meaningless in a ~S SB." (sb-kind sb)))) @@ -153,8 +157,8 @@ (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))))) + :key (lambda (x) + (sb-name (sc-sb x))))) t nil))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) @@ -176,7 +180,7 @@ (let ((old (svref *backend-sc-numbers* ',number))) (when (and old (not (eq (sc-name old) ',name))) - (warn "redefining SC number ~D from ~S to ~S" ',number + (warn "redefining SC number ~W from ~S to ~S" ',number (sc-name old) ',name))) (setf (svref *backend-sc-numbers* ',number) @@ -205,9 +209,9 @@ ;;; of this move operation. The function is called with three ;;; arguments: the VOP (for 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-MOVE-FUN should be compiled before any uses of ;;; DEFINE-VOP. -(defmacro define-move-function ((name cost) lambda-list scs &body body) +(defmacro define-move-fun ((name cost) lambda-list scs &body body) (declare (type index cost)) (when (or (oddp (length scs)) (null scs)) (error "malformed SCs spec: ~S" scs)) @@ -216,7 +220,7 @@ (do-sc-pairs (from-sc to-sc ',scs) (unless (eq from-sc to-sc) (let ((num (sc-number from-sc))) - (setf (svref (sc-move-functions to-sc) num) ',name) + (setf (svref (sc-move-funs to-sc) num) ',name) (setf (svref (sc-load-costs to-sc) num) ',cost))))) (defun ,name ,lambda-list @@ -226,16 +230,17 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *sc-vop-slots* '((:move . sc-move-vops) - (:move-argument . sc-move-arg-vops)))) + (:move-arg . sc-move-arg-vops)))) +;;; Make NAME be the VOP used to move values in the specified FROM-SCs +;;; to the representation of the TO-SCs of each SC pair in SCS. +;;; +;;; If KIND is :MOVE-ARG, then the VOP takes an extra argument, +;;; which is the frame pointer of the frame to move into. +;;; ;;; We record the VOP and costs for all SCs that we can move between ;;; (including implicit loading). (defmacro define-move-vop (name kind &rest scs) - #!+sb-doc - "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*)) @@ -273,8 +278,7 @@ ;;; type descriptor for the Lisp type that is equivalent to this type. (defmacro !def-primitive-type (name scs &key (type name)) (declare (type symbol name) (type list scs)) - (let ((scns (mapcar #'meta-sc-number-or-lose scs)) - (ctype-form `(specifier-type ',type))) + (let ((scns (mapcar #'meta-sc-number-or-lose scs))) `(progn (/show0 "doing !DEF-PRIMITIVE-TYPE, NAME=..") (/primitive-print ,(symbol-name name)) @@ -282,9 +286,8 @@ (setf (gethash ',name *backend-meta-primitive-type-names*) (make-primitive-type :name ',name :scs ',scns - :type ,ctype-form))) - ,(once-only ((n-old `(gethash ',name *backend-primitive-type-names*)) - (n-type ctype-form)) + :specifier ',type))) + ,(once-only ((n-old `(gethash ',name *backend-primitive-type-names*))) `(progn ;; If the PRIMITIVE-TYPE structure already exists, we ;; destructively modify it so that existing references in @@ -298,13 +301,13 @@ (cond (,n-old (/show0 "in ,N-OLD clause of COND") (setf (primitive-type-scs ,n-old) ',scns) - (setf (primitive-type-type ,n-old) ,n-type)) + (setf (primitive-type-specifier ,n-old) ',type)) (t (/show0 "in T clause of COND") (setf (gethash ',name *backend-primitive-type-names*) (make-primitive-type :name ',name :scs ',scns - :type ,n-type)))) + :specifier ',type)))) (/show0 "done with !DEF-PRIMITIVE-TYPE") ',name))))) @@ -318,33 +321,33 @@ (defparameter *primitive-type-slot-alist* '((:check . primitive-type-check))) +;;; Primitive-Type-VOP Vop (Kind*) Type* +;;; +;;; Annotate all the specified primitive Types with the named VOP +;;; under each of the specified kinds: +;;; +;;; :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. (defmacro primitive-type-vop (vop kinds &rest types) - #!+sb-doc - "Primitive-Type-VOP Vop (Kind*) Type* - Annotate all the specified primitive Types with the named VOP under each of - the specified kinds: - - :Check - A one argument one result VOP that moves the argument to the result, - checking that the value is of this type in the process." (let ((n-vop (gensym)) (n-type (gensym))) `(let ((,n-vop (template-or-lose ',vop))) ,@(mapcar - #'(lambda (type) - `(let ((,n-type (primitive-type-or-lose ',type))) - ,@(mapcar - #'(lambda (kind) - (let ((slot (or (cdr (assoc kind - *primitive-type-slot-alist*)) - (error "unknown kind: ~S" kind)))) - `(setf (,slot ,n-type) ,n-vop))) - kinds))) + (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 SC's -;;; alternate or constant SCs. +;;; Return true if SC is either one of PTYPE's SC's, or one of those +;;; SC's alternate or constant SCs. (defun meta-sc-allowed-by-primitive-type (sc ptype) (declare (type sc sc) (type primitive-type ptype)) (let ((scn (sc-number sc))) @@ -404,7 +407,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) @@ -415,13 +418,13 @@ (effects '(any) :type list) (affected '(any) :type list) ;; a list of the names of functions this VOP is a translation of and - ;; the policy that allows this translation to be done. :Fast is a + ;; the policy that allows this translation to be done. :FAST is a ;; safe default, since it isn't a safe policy. (translate () :type list) (ltn-policy :fast :type ltn-policy) ;; stuff used by life analysis (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 + ;; info about how to emit MOVE-ARG VOPs for the &MORE operand in ;; call/return VOPs (move-args nil :type (member nil :local-call :full-call :known-return))) (defprinter (vop-parse) @@ -465,10 +468,7 @@ ;; 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 +479,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 @@ -517,9 +517,9 @@ (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 -;;; meta-compile time uses, the VOP-Parse should be used instead of -;;; the VOP-Info. +;;; Get the VOP-PARSE structure for NAME or die trying. For all +;;; meta-compile time uses, the VOP-PARSE should be used instead of +;;; the VOP-INFO. (defun vop-parse-or-lose (name) (the vop-parse (or (gethash name *backend-parsed-vops*) @@ -527,8 +527,8 @@ ;;; 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)) @@ -542,9 +542,9 @@ (res `(,(operand-parse-name more-operand) ,prev)))) (res))) -;;; This is used with ACCESS-OPERANDS to prevent warnings for TN-Ref +;;; 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))))) @@ -637,6 +637,9 @@ (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 @@ -647,7 +650,9 @@ (+ (* (position-or-lose target (vop-parse-temps parse)) 2) - num-args num-results))))))) + 1 + num-args + num-results))))))) (let ((born (operand-parse-born op)) (dies (operand-parse-dies op))) (ecase (operand-parse-kind op) @@ -665,17 +670,25 @@ (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))) + (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)) - (oe-type '(mod #.max-vop-tn-refs)) ; :REF-ORDERING element type - (te-type '(mod #.(* max-vop-tn-refs 2))) ; :TARGETS element type + ;; :REF-ORDERING element type + ;; + ;; KLUDGE: was (MOD #.MAX-VOP-TN-REFS), which is still right + (oe-type '(unsigned-byte 8)) + ;; :TARGETS element-type + ;; + ;; KLUDGE: was (MOD #.(* MAX-VOP-TN-REFS 2)), which does + ;; not correspond to the definition in + ;; src/compiler/vop.lisp. + (te-type '(unsigned-byte 16)) (ordering (make-specializable-array (length sorted) :element-type oe-type))) @@ -721,7 +734,7 @@ ;;; from to the move function used for loading those SCs. We quietly ;;; ignore restrictions to :non-packed (constant) and :unbounded SCs, ;;; since we don't load into those SCs. -(defun find-move-functions (op load-p) +(defun find-move-funs (op load-p) (collect ((funs)) (dolist (sc-name (operand-parse-scs op)) (let* ((sc (meta-sc-or-lose sc-name)) @@ -735,19 +748,19 @@ (unless (member (sc-name alt) (operand-parse-scs op) :test #'eq) (let* ((altn (sc-number alt)) (name (if load-p - (svref (sc-move-functions sc) altn) - (svref (sc-move-functions alt) scn))) + (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" + ~:[to~;from~] from SC ~S" load-p sc-name load-p (sc-name alt))) (cond (found (unless (eq (cdr found) name) (error "can't tell whether to ~:[save~;load~]~@ - or ~S when operand is in SC ~S" + with ~S or ~S when operand is in SC ~S" load-p name (cdr found) (sc-name alt))) (pushnew alt (car found))) (t @@ -755,7 +768,7 @@ ((member (sb-kind (sc-sb sc)) '(:non-packed :unbounded))) (t (error "SC ~S has no alternate~:[~; or constant~] SCs, yet it is~@ - mentioned in the restriction for operand ~S" + mentioned in the restriction for operand ~S" sc-name load-p (operand-parse-name op)))))) (funs))) @@ -765,22 +778,22 @@ ;;; move function, then we just call that when there is a load TN. If ;;; there are multiple possible move functions, then we dispatch off ;;; of the operand TN's type to see which move function to use. -(defun call-move-function (parse op load-p) - (let ((funs (find-move-functions op load-p)) +(defun call-move-fun (parse op load-p) + (let ((funs (find-move-funs op load-p)) (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)))) + (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)))) + ,@(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) @@ -791,7 +804,7 @@ ,form))) `(when ,load-tn (error "load TN allocated, but no move function?~@ - VM definition is inconsistent, recompile and try again."))))) + VM definition is inconsistent, recompile and try again."))))) ;;; Return the TN that we should bind to the operand's var in the ;;; generator body. In general, this involves evaluating the :LOAD-IF @@ -816,7 +829,7 @@ ,load-tn (tn-ref-tn ,temp)))))) -;;; Make a lambda that parses the VOP TN-Refs, does automatic operand +;;; 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)) @@ -836,8 +849,8 @@ (tn-ref-load-tn ,temp))) (binds `(,name ,(decide-to-load parse op))) (if (eq (operand-parse-kind op) :argument) - (loads (call-move-function parse op t)) - (saves (call-move-function parse op nil)))) + (loads (call-move-fun parse op t)) + (saves (call-move-fun parse op nil)))) (t (binds `(,name (tn-ref-tn ,temp))))))) (:temporary @@ -845,10 +858,10 @@ (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)) + `(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)) @@ -856,21 +869,31 @@ `(vop-temps ,n-vop)) ,@(when (vop-parse-info-args parse) `((,n-info (vop-codegen-info ,n-vop)) - ,@(mapcar #'(lambda (x) `(,x (pop ,n-info))) + ,@(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))) + ,@(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)))))) + (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 () + ;; FIXME: potentially causes breakage in contribs from locked + ;; packages. + (intern (format nil "OPERAND-PARSE-TEMP-~D" *parse-vop-operand-count*) + (symbol-package '*parse-vop-operand-count*))) +(defun make-operand-parse-load-tn () + (intern (format nil "OPERAND-PARSE-LOAD-TN-~D" *parse-vop-operand-count*) + (symbol-package '*parse-vop-operand-count*))) + ;;; Given a list of operand specifications as given to DEFINE-VOP, ;;; return a list of OPERAND-PARSE structures describing the fixed ;;; operands, and a single OPERAND-PARSE describing any more operand. @@ -887,6 +910,7 @@ (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 @@ -975,9 +999,9 @@ (dolist (name (cddr spec)) (unless (symbolp name) (error "bad temporary name: ~S" name)) + (incf *parse-vop-operand-count*) (let ((res (make-operand-parse :name name :kind :temporary - :temp-temp (gensym) :born (parse-time-spec :load) :dies (parse-time-spec :save)))) (do ((opt (second spec) (cddr opt))) @@ -1022,87 +1046,102 @@ :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) 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 @@ -1133,7 +1172,7 @@ (aref (sc-load-costs op-sc) load-scn)))) (unless load (error "no move function defined to move ~:[from~;to~] SC ~ - ~S~%~:[to~;from~] alternate or constant SC ~S" + ~S~%~:[to~;from~] alternate or constant SC ~S" load-p sc-name load-p (sc-name op-sc))) (let ((op-cost (svref costs op-scn))) @@ -1234,7 +1273,7 @@ (let ((alias (parse-operand-type alias))) (unless (eq (car alias) :or) (error "can't include primitive-type ~ - alias ~S in an :OR restriction: ~S" + alias ~S in an :OR restriction: ~S" item spec)) (dolist (x (cdr alias)) (results x))) @@ -1252,7 +1291,7 @@ (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. ;;; @@ -1273,10 +1312,10 @@ nil) (when (svref load-scs rep) (return t))) (error "In the ~A ~:[result~;argument~] to VOP ~S,~@ - none of the SCs allowed by the operand type ~S can ~ - directly be loaded~@ - into any of the restriction's SCs:~% ~S~:[~;~@ - [* type operand must allow T's SCs.]~]" + none of the SCs allowed by the operand type ~S can ~ + directly be loaded~@ + into any of the restriction's SCs:~% ~S~:[~;~@ + [* type operand must allow T's SCs.]~]" (operand-parse-name op) load-p (vop-parse-name parse) ptype scs (eq type '*))))) @@ -1289,8 +1328,8 @@ (meta-primitive-type-or-lose ptype)) (return t)))) (warn "~:[Result~;Argument~] ~A to VOP ~S~@ - has SC restriction ~S which is ~ - not allowed by the operand type:~% ~S" + has SC restriction ~S which is ~ + not allowed by the operand type:~% ~S" load-p (operand-parse-name op) (vop-parse-name parse) sc type))))) @@ -1304,12 +1343,12 @@ (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))) + (unless (= (count-if-not (lambda (x) + (and (consp x) + (eq (car x) :constant))) types) num) - (error "expected ~D ~:[result~;argument~] type~P: ~S" + (error "expected ~W ~:[result~;argument~] type~P: ~S" num load-p types num))) (when more-op @@ -1319,18 +1358,18 @@ (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)) + (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))) + (remove-if (lambda (x) + (and (consp x) + (eq (car x) ':constant))) (if more-op (butlast types) types))))) (values)) ;;; Compute stuff that can only be computed after we are done parsing -;;; everying. We set the VOP-Parse-Operands, and do various error checks. +;;; everying. We set the VOP-PARSE-OPERANDS, and do various error checks. (defun !grovel-vop-operands (parse) (declare (type vop-parse parse)) @@ -1360,22 +1399,21 @@ ;;;; function translation stuff ;;; Return forms to establish this VOP as a IR2 translation template -;;; for the :TRANSLATE functions specified in the VOP-Parse. We also -;;; set the Predicate attribute for each translated function when the +;;; for the :TRANSLATE functions specified in the VOP-PARSE. We also +;;; set the PREDICATE attribute for each translated function when the ;;; VOP is conditional, causing IR1 conversion to ensure that a call ;;; to the translated is always used in a predicate position. -(defun set-up-function-translation (parse n-template) +(defun !set-up-fun-translation (parse n-template) (declare (type vop-parse parse)) - (mapcar #'(lambda (name) - `(let ((info (function-info-or-lose ',name))) - (setf (function-info-templates info) - (adjoin-template ,n-template - (function-info-templates info))) - ,@(when (vop-parse-conditional-p parse) - '((setf (function-info-attributes info) - (attributes-union - (ir1-attributes predicate) - (function-info-attributes info))))))) + (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))) ;;; Return a form that can be evaluated to get the TEMPLATE operand type @@ -1387,9 +1425,9 @@ (t (ecase (first type) (:or - ``(:or ,,@(mapcar #'(lambda (type) - `(primitive-type-or-lose ',type)) - (rest type)))) + ``(:or ,,@(mapcar (lambda (type) + `(primitive-type-or-lose ',type)) + (rest type)))) (:constant ``(:constant ,#'(lambda (x) (typep x ',(second type))) @@ -1434,13 +1472,13 @@ (defparameter *slot-inherit-alist* '((:generator-function . vop-info-generator-function)))) -;;; This is something to help with inheriting VOP-Info slots. We +;;; This is something to help with inheriting VOP-INFO slots. We ;;; return a keyword/value pair that can be passed to the constructor. ;;; SLOT is the keyword name of the slot, Parse is a form that -;;; evaluates to the VOP-Parse structure for the VOP inherited. If +;;; evaluates to the VOP-PARSE structure for the VOP inherited. If ;;; PARSE is NIL, then we do nothing. If the TEST form evaluates to ;;; true, then we return a form that selects the named slot from the -;;; VOP-Info structure corresponding to PARSE. Otherwise, we return +;;; VOP-INFO structure corresponding to PARSE. Otherwise, we return ;;; the FORM so that the slot is recomputed. (defmacro inherit-vop-info (slot parse test form) `(if (and ,parse ,test) @@ -1449,7 +1487,7 @@ (template-or-lose ',(vop-parse-name ,parse)))) (list ,slot ,form))) -;;; Return a form that creates a VOP-Info structure which describes VOP. +;;; 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 @@ -1462,13 +1500,13 @@ (let ((nvars (length (vop-parse-variant-vars parse)))) (unless (= (length variant) nvars) - (error "expected ~D 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,24 +1529,24 @@ ;;; keyword indicating the interpretation of the other forms in the ;;; SPEC: ;;; -;;; :Args {(Name {Key Value}*)}* -;;; :Results {(Name {Key Value}*)}* +;;; :ARGS {(Name {Key Value}*)}* +;;; :RESULTS {(Name {Key Value}*)}* ;;; The Args and Results are specifications of the operand TNs passed ;;; to the VOP. If there is an inherited VOP, any unspecified options ;;; are defaulted from the inherited argument (or result) of the same ;;; name. The following operand options are defined: ;;; -;;; :SCs (SC*) -;;; :SCs specifies good SCs for this operand. Other SCs will be -;;; penalized according to move costs. A load TN will be allocated if -;;; necessary, guaranteeing that the operand is always one of the -;;; specified SCs. +;;; :SCs (SC*) +;;; :SCs specifies good SCs for this operand. Other SCs will +;;; be penalized according to move costs. A load TN will be +;;; allocated if necessary, guaranteeing that the operand is +;;; always one of the specified SCs. ;;; -;;; :Load-TN Load-Name -;;; Load-Name is bound to the load TN allocated for this operand, -;;; or to NIL if no load TN was allocated. +;;; :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 +;;; :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 @@ -1516,56 +1554,57 @@ ;;; 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 +;;; :MORE T-or-NIL +;;; If specified, NAME is bound to the TN-REF for the first ;;; argument or result following the fixed arguments or results. ;;; A :MORE operand must appear last, and cannot be targeted or ;;; restricted. ;;; -;;; :Target Operand +;;; :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 +;;; :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 +;;; :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 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 +;;; A side effect is to set the PREDICATE attribute for functions ;;; in the :TRANSLATE option. ;;; -;;; :Temporary ({Key Value}*) Name* +;;; :TEMPORARY ({Key Value}*) Name* ;;; Allocate a temporary TN for each Name, binding that variable to ;;; the TN within the body of the generators. In addition to :TARGET ;;; (which is is the same as for operands), the following options are ;;; defined: ;;; ;;; :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. 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. +;;; :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 +;;; 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 -;;; 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. Non-zero sub-phases can be specified -;;; by a list, e.g. by default the second argument's life ends at -;;; (:Argument 1). +;;; :FROM Time-Spec +;;; :TO Time-Spec +;;; 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. +;;; 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* +;;; :GENERATOR Cost Form* ;;; Specifies the translation into assembly code. Cost is the ;;; estimated cost of the code emitted by this generator. The body ;;; is arbitrary Lisp code that emits the assembly language @@ -1574,72 +1613,73 @@ ;;; During the evaluation of the body, the names of the operands ;;; and temporaries are bound to the actual TNs. ;;; -;;; :Effects Effect* -;;; :Affected Effect* +;;; :EFFECTS Effect* +;;; :AFFECTED Effect* ;;; Specifies the side effects that this VOP has and the side ;;; effects that effect its execution. If unspecified, these ;;; default to the worst case. ;;; -;;; :Info Name* +;;; :INFO Name* ;;; Define some magic arguments that are passed directly to the code ;;; generator. The corresponding trailing arguments to VOP or ;;; %PRIMITIVE are stored in the VOP structure. Within the body ;;; of the generators, the named variables are bound to these -;;; values. Except in the case of :Conditional VOPs, :Info arguments +;;; values. Except in the case of :CONDITIONAL VOPs, :INFO arguments ;;; cannot be specified for VOPS that are the direct translation -;;; for a function (specified by :Translate). +;;; for a function (specified by :TRANSLATE). ;;; -;;; :Ignore Name* +;;; :IGNORE Name* ;;; Causes the named variables to be declared IGNORE in the ;;; generator body. ;;; -;;; :Variant Thing* -;;; :Variant-Vars Name* +;;; :VARIANT Thing* +;;; :VARIANT-VARS Name* ;;; These options provide a way to parameterize families of VOPs -;;; that differ only trivially. :Variant makes the specified +;;; that differ only trivially. :VARIANT makes the specified ;;; evaluated Things be the "variant" associated with this VOP. ;;; :VARIANT-VARS causes the named variables to be bound to the ;;; corresponding Things within the body of the generator. ;;; -;;; :Variant-Cost Cost +;;; :VARIANT-COST Cost ;;; Specifies the cost of this VOP, overriding the cost of any ;;; inherited generator. ;;; -;;; :Note {String | NIL} +;;; :NOTE {String | NIL} ;;; A short noun-like phrase describing what this VOP "does", i.e. ;;; the implementation strategy. If supplied, efficiency notes will ;;; be generated when type uncertainty prevents :TRANSLATE from ;;; working. NIL inhibits any efficiency note. ;;; -;;; :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. :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. +;;; :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. :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* +;;; :TRANSLATE Name* ;;; This option causes the VOP template to be entered as an IR2 ;;; translation for the named functions. ;;; -;;; :Policy {:Small | :Fast | :Safe | :Fast-Safe} +;;; :POLICY {:SMALL | :FAST | :SAFE | :FAST-SAFE} ;;; Specifies the policy under which this VOP is the best translation. ;;; -;;; :Guard Form -;;; Specifies a Form that is evaluated in the global environment. If -;;; form returns NIL, then emission of this VOP is prohibited even when -;;; all other restrictions are met. +;;; :GUARD Form +;;; Specifies a Form that is evaluated in the global environment. +;;; If form returns NIL, then emission of this VOP is prohibited +;;; even when all other restrictions are met. ;;; -;;; :VOP-Var Name -;;; :Node-Var Name +;;; :VOP-VAR Name +;;; :NODE-VAR Name ;;; In the generator, bind the specified variable to the VOP or ;;; the Node that generated this VOP. ;;; -;;; :Save-P {NIL | T | :Compute-Only | :Force-To-Stack} +;;; :SAVE-P {NIL | T | :COMPUTE-ONLY | :FORCE-TO-STACK} ;;; Indicates how a VOP wants live registers saved. ;;; -;;; :Move-Args {NIL | :Full-Call | :Local-Call | :Known-Return} +;;; :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) @@ -1669,18 +1709,18 @@ (setf (gethash ',name *backend-template-names*) ,n-res) (setf (template-type ,n-res) (specifier-type (template-type-specifier ,n-res))) - ,@(set-up-function-translation parse n-res)) + ,@(!set-up-fun-translation parse n-res)) ',name))) ;;;; emission macros ;;; Return code to make a list of VOP arguments or results, linked by -;;; TN-Ref-Across. The first value is code, the second value is LET* +;;; TN-REF-ACROSS. The first value is code, the second value is LET* ;;; forms, and the third value is a variable that evaluates to the ;;; head of the list, or NIL if there are no operands. Fixed is a list -;;; of forms that evaluate to TNs for the fixed operands. TN-Refs will +;;; of forms that evaluate to TNs for the fixed operands. TN-REFS will ;;; be made for these operands according using the specified value of -;;; Write-P. More is an expression that evaluates to a list of TN-Refs +;;; WRITE-P. More is an expression that evaluates to a list of TN-REFS ;;; that will be made the tail of the list. If it is constant NIL, ;;; then we don't bother to set the tail. (defun make-operand-list (fixed more write-p) @@ -1707,8 +1747,8 @@ ;;; Emit-Template Node Block Template Args Results [Info] ;;; -;;; Call the emit function for Template, linking the result in at the -;;; end of Block. +;;; 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))) @@ -1723,18 +1763,18 @@ ;;; VOP Name Node Block Arg* Info* Result* ;;; -;;; Emit the VOP (or other template) Name at the end of the IR2-Block -;;; Block, using Node for the source context. The interpretation of +;;; Emit the VOP (or other template) NAME at the end of the IR2-BLOCK +;;; BLOCK, using NODE for the source context. The interpretation of ;;; the remaining arguments depends on the number of operands of ;;; various kinds that are declared in the template definition. VOP ;;; cannot be used for templates that have more-args or more-results, ;;; since the number of arguments and results is indeterminate for ;;; these templates. Use VOP* instead. ;;; -;;; Args and Results are the TNs that are to be referenced by the +;;; ARGS and RESULTS are the TNs that are to be referenced by the ;;; template as arguments and results. If the template has -;;; codegen-info arguments, then the appropriate number of Info forms -;;; following the Arguments are used for codegen info. +;;; codegen-info arguments, then the appropriate number of INFO forms +;;; 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))) @@ -1748,14 +1788,14 @@ (when (or (vop-parse-more-args parse) (vop-parse-more-results parse)) (error "cannot use VOP with variable operand count templates")) (unless (= noperands (length operands)) - (error "called with ~D operands, but was expecting ~D" + (error "called with ~W operands, but was expecting ~W" (length operands) noperands)) (multiple-value-bind (acode abinds n-args) (make-operand-list (subseq operands 0 arg-count) nil nil) (multiple-value-bind (rcode rbinds n-results) (make-operand-list (subseq operands (+ arg-count info-count)) nil t) - + (collect ((ibinds) (ivars)) (dolist (info (subseq operands arg-count (+ arg-count info-count))) @@ -1781,16 +1821,16 @@ ;;; ;;; This is like VOP, but allows for emission of templates with ;;; arbitrary numbers of arguments, and for emission of templates -;;; using already-created TN-Ref lists. +;;; using already-created TN-REF lists. ;;; -;;; The Arguments and Results are TNs to be referenced as the first +;;; The ARGS and RESULTS are TNs to be referenced as the first ;;; arguments and results to the template. More-Args and More-Results -;;; are heads of TN-Ref lists that are added onto the end of the -;;; TN-Refs for the explicitly supplied operand TNs. The TN-Refs for -;;; the more operands must have the TN and Write-P slots correctly +;;; are heads of TN-REF lists that are added onto the end of the +;;; TN-REFS for the explicitly supplied operand TNs. The TN-REFS for +;;; the more operands must have the TN and WRITE-P slots correctly ;;; initialized. ;;; -;;; As with VOP, the Info forms are evaluated and passed as codegen +;;; As with VOP, the INFO forms are evaluated and passed as codegen ;;; info arguments. (defmacro vop* (name node block args results &rest info) (declare (type cons args results)) @@ -1811,13 +1851,13 @@ (<= (length fixed-results) result-count)) (error "too many fixed results")) (unless (= (length info) info-count) - (error "expected ~D info args" 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) (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)) @@ -1845,20 +1885,20 @@ (collect ((clauses)) (do ((cases forms (rest cases))) ((null cases) - (clauses `(t (error "unknown SC to SC-Case for ~S:~% ~S" ,n-tn + (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)) + (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.")) + (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)) + (clauses `((or ,@(mapcar (lambda (x) + `(eql ,(meta-sc-number-or-lose x) + ,n-sc)) (if (atom head) (list head) head))) nil ,@(rest case)))))) @@ -1869,8 +1909,8 @@ ;;; 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))) + `(or ,@(mapcar (lambda (x) + `(eql ,n-sc ,(meta-sc-number-or-lose x))) scs)))) ;;; Iterate over the IR2 blocks in component, in emission order. @@ -1882,7 +1922,7 @@ ,@forms)) ;;; Iterate over all the TNs live at some point, with the live set -;;; represented by a local conflicts bit-vector and the IR2-Block +;;; 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)) @@ -1901,9 +1941,9 @@ (,n-bod ,tn-var)) (let ((,ltns (ir2-block-local-tns ,n-block))) - ;; Do TNs always-live in this block and live :More TNs. + ;; Do TNs always-live in this block and live :MORE TNs. (do ((,n-conf (ir2-block-global-tns ,n-block) - (global-conflicts-next ,n-conf))) + (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))) @@ -1921,9 +1961,7 @@ (defmacro do-physenv-ir2-blocks ((block-var physenv &optional result) &body body) (once-only ((n-physenv physenv)) - (once-only ((n-first `(node-block - (lambda-bind - (physenv-function ,n-physenv))))) + (once-only ((n-first `(lambda-block (physenv-lambda ,n-physenv)))) (once-only ((n-tail `(block-info (component-tail (block-component ,n-first)))))