X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmeta-vmdef.lisp;h=9751d9938f4381508a7c503d8da9d9907a9debc7;hb=82653abf5573c22c691e2243b70647ecdaa6aea8;hp=8c542f9682c63a95cb81452ce0775652924ad5b1;hpb=95a6db7329b91dd90d165dd4057b9b5098d34aa2;p=sbcl.git diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp index 8c542f9..9751d99 100644 --- a/src/compiler/meta-vmdef.lisp +++ b/src/compiler/meta-vmdef.lisp @@ -20,21 +20,17 @@ ;;;; storage class and storage base definition -;;; Enter the basic structure at meta-compile time, and then fill in the -;;; missing slots at load time. +;;; Define a storage base having the specified NAME. KIND may be :FINITE, +;;; :UNBOUNDED or :NON-PACKED. The following keywords are legal: +;;; :SIZE specifies the number of locations in a :FINITE SB or +;;; the initial size of an :UNBOUNDED SB. +;;; +;;; 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) - #!+sb-doc - "Define-Storage-Base Name Kind {Key Value}* - Define a storage base having the specified Name. Kind may be :Finite, - :Unbounded or :Non-Packed. The following keywords are legal: - :Size - Specify the number of locations in a :Finite SB or the initial size of a - :Unbounded SB." - - ;; FIXME: Replace with DECLARE. - (check-type name symbol) - (check-type kind (member :finite :unbounded :non-packed)) + (declare (type symbol name)) + (declare (type (member :finite :unbounded :non-packed) kind)) ;; SIZE is either mandatory or forbidden. (ecase kind @@ -43,7 +39,7 @@ (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)) - (check-type size unsigned-byte))) + (aver (typep size 'unsigned-byte)))) (let ((res (if (eq kind :non-packed) (make-sb :name name :kind kind) @@ -63,10 +59,11 @@ (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. + ;; 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") @@ -86,66 +83,60 @@ (/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: +;;; +;;; :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. +;;; +;;; :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*) +;;; 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} +;;; If T, then values stored in this SC must be saved in one of the +;;; non-save-p :Alternate-SCs across calls. +;;; +;;; :Alternate-SCs (SC*) +;;; Indicates other SCs that can be used to hold values from this SC across +;;; calls or when storage in this SC is exhausted. The SCs should be +;;; specified in order of decreasing \"goodness\". 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*) +;;; 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) - #!+sb-doc - "Define-Storage-Class Name Number Storage-Base {Key Value}* - Define a storage class Name that uses the named Storage-Base. Number is a - small, non-negative integer that is used as an alias. The following - keywords are defined: - - :Element-Size Size - 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. - - :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*) - 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} - If T, then values stored in this SC must be saved in one of the - non-save-p :Alternate-SCs across calls. - - :Alternate-SCs (SC*) - Indicates other SCs that can be used to hold values from this SC across - calls or when storage in this SC is exhausted. The SCs should be - specified in order of decreasing \"goodness\". 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*) - A list of the names of all the constant SCs that can be loaded into this - SC by a move function." - - (check-type name symbol) - (check-type number sc-number) - (check-type sb-name symbol) - (check-type locations list) - (check-type reserve-locations list) - (check-type save-p boolean) - (check-type alternate-scs list) - (check-type constant-scs list) + (declare (type symbol name)) + (declare (type sc-number number)) + (declare (type symbol sb-name)) + (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) (let ((size (sb-size sb)) (element-size (eval element-size))) - (check-type element-size unsigned-byte) + (declare (type unsigned-byte element-size)) (dolist (el locations) - (check-type el unsigned-byte) + (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)))) @@ -162,8 +153,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) @@ -185,7 +176,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) @@ -209,24 +200,23 @@ (let ((,to-sc-var (meta-sc-or-lose to))) ,@body)))))) -(defmacro define-move-function ((name cost) lambda-list scs &body body) - #!+sb-doc - "Define-Move-Function (Name Cost) lambda-list ({(From-SC*) (To-SC*)}*) form* - Define the function Name and note it as the function used for moving operands - from the From-SCs to the To-SCs. Cost is the cost of this move operation. - The function is called with three arguments: the 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-VOP." +;;; Define the function NAME and note it as the function used for +;;; moving operands from the From-SCs to the To-SCs. Cost is the cost +;;; of this move operation. The function is called with three +;;; arguments: the VOP (for context), and the source and destination +;;; TNs. An ASSEMBLE form is wrapped around the body. All uses of +;;; DEFINE-MOVE-FUN should be compiled before any uses of +;;; DEFINE-VOP. +(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)) - (check-type cost index) `(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-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 @@ -236,16 +226,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*)) @@ -278,46 +269,49 @@ (or (gethash name *backend-meta-primitive-type-names*) (error "~S is not a defined primitive type." name)))) -;;; If the primitive-type structure already exists, we destructively modify -;;; it so that existing references in templates won't be invalidated. -(defmacro def-primitive-type (name scs &key (type name)) - #!+sb-doc - "Def-Primitive-Type Name (SC*) {Key Value}* - Define a primitive type Name. Each SC specifies a Storage Class that values - of this type may be allocated in. The following keyword options are - defined: - - :Type - The type descriptor for the Lisp type that is equivalent to this type - (defaults to Name.)" - (check-type name symbol) - (check-type scs list) +;;; Define a primitive type NAME. Each SCS entry specifies a storage +;;; class that values of this type may be allocated in. TYPE is the +;;; 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)) - (get-type `(specifier-type ',type))) + (ctype-form `(specifier-type ',type))) `(progn + (/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 - :type ,get-type))) + :type ,ctype-form))) ,(once-only ((n-old `(gethash ',name *backend-primitive-type-names*)) - (n-type get-type)) + (n-type ctype-form)) `(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-type ,n-old) ,n-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)))) + (/show0 "done with !DEF-PRIMITIVE-TYPE") ',name))))) -;;; Just record the translation. -(defmacro def-primitive-type-alias (name result) - #!+sb-doc - "DEF-PRIMITIVE-TYPE-ALIAS Name Result - Define name to be an alias for Result in VOP operand type restrictions." +;;; Define NAME to be an alias for RESULT in VOP operand type restrictions. +(defmacro !def-primitive-type-alias (name result) + ;; Just record the translation. `(eval-when (:compile-toplevel :load-toplevel :execute) (setf (gethash ',name *backend-primitive-type-aliases*) ',result) ',name)) @@ -338,15 +332,15 @@ (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))) @@ -365,70 +359,72 @@ ;;;; VOP definition structures ;;;; -;;;; Define-VOP uses some fairly complex data structures at meta-compile -;;;; time, both to hold the results of parsing the elaborate syntax and to -;;;; retain the information so that it can be inherited by other VOPs. +;;;; DEFINE-VOP uses some fairly complex data structures at +;;;; meta-compile time, both to hold the results of parsing the +;;;; elaborate syntax and to retain the information so that it can be +;;;; inherited by other VOPs. -;;; The VOP-Parse structure holds everything we need to know about a VOP at +;;; 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)) - ;; The name of this VOP. + ;; the name of this VOP (name nil :type symbol) ;; If true, then the name of the VOP we inherit from. (inherits nil :type (or symbol null)) - ;; Lists of Operand-Parse structures describing the arguments, results and - ;; temporaries of the VOP. + ;; lists of OPERAND-PARSE structures describing the arguments, + ;; results and temporaries of the VOP (args nil :type list) (results nil :type list) (temps nil :type list) - ;; Operand-Parse structures containing information about more args and - ;; results. If null, then there there are no more operands of that kind. + ;; OPERAND-PARSE structures containing information about more args + ;; and results. If null, then there there are no more operands of + ;; that kind (more-args nil :type (or operand-parse null)) (more-results nil :type (or operand-parse null)) - ;; A list of all the above together. + ;; a list of all the above together (operands nil :type list) - ;; Names of variables that should be declared ignore. + ;; 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 (conditional-p nil) - ;; Argument and result primitive types. These are pulled out of the - ;; operands, since we often want to change them without respecifying the - ;; operands. + ;; argument and result primitive types. These are pulled out of the + ;; operands, since we often want to change them without respecifying + ;; the operands. (arg-types :unspecified :type (or (member :unspecified) list)) (result-types :unspecified :type (or (member :unspecified) list)) - ;; The guard expression specified, or NIL if none. + ;; the guard expression specified, or NIL if none (guard nil) - ;; The cost of and body code for the generator. + ;; the cost of and body code for the generator (cost 0 :type unsigned-byte) (body :unspecified :type (or (member :unspecified) list)) - ;; Info for VOP variants. The list of forms to be evaluated to get the - ;; variant args for this VOP, and the list of variables to be bound to the - ;; variant args. + ;; info for VOP variants. The list of forms to be evaluated to get + ;; the variant args for this VOP, and the list of variables to be + ;; bound to the variant args. (variant () :type list) (variant-vars () :type list) - ;; Variables bound to the VOP and Vop-Node when in the generator body. + ;; variables bound to the VOP and Vop-Node when in the generator body (vop-var (gensym) :type symbol) (node-var nil :type (or symbol null)) - ;; A list of the names of the codegen-info arguments to this VOP. + ;; a list of the names of the codegen-info arguments to this VOP (info-args () :type list) - ;; An efficiency note associated with this VOP. + ;; an efficiency note associated with this VOP (note nil :type (or string null)) - ;; A list of the names of the Effects and Affected attributes for this VOP. + ;; a list of the names of the Effects and Affected attributes for + ;; this VOP (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 safe default, - ;; since it isn't a safe policy. + ;; 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. (translate () :type list) - (policy :fast :type policies) - ;; Stuff used by life analysis. + (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 - ;; call/return VOPs. + ;; 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) name (inherits :test inherits) @@ -450,47 +446,48 @@ effects affected translate - policy + ltn-policy (save-p :test save-p) (move-args :test move-args)) -;;; An OPERAND-PARSE object contains stuff we need to know about an operand or -;;; temporary at meta-compile time. Besides the obvious stuff, we also store -;;; the names of per-operand temporaries here. +;;; An OPERAND-PARSE object contains stuff we need to know about an +;;; 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)) - ;; Name of the operand (which we bind to the TN). + ;; name of the operand (which we bind to the TN) (name nil :type symbol) - ;; The way this operand is used: - (kind (required-argument) + ;; the way this operand is used: + (kind (missing-arg) :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. + ;; 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)) - ;; Temporary that holds the TN-Ref for this operand. Temp-Temp holds the - ;; write reference that begins a temporary's lifetime. + ;; 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)) - ;; 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. + ;; 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. born dies - ;; A list of the names of the SCs that this operand is allowed into. If - ;; false, there is no restriction. + ;; a list of the names of the SCs that this operand is allowed into. + ;; If false, there is no restriction. (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) - ;; An expression that tests whether to do automatic operand loading. + ;; 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 packed - ;; in. Null otherwise. + ;; In a wired or restricted temporary this is the SC the TN is to be + ;; packed in. Null otherwise. (sc nil :type (or symbol null)) ;; If non-null, we are a temp wired to this offset in SC. (offset nil :type (or unsigned-byte null))) - (defprinter (operand-parse) name kind @@ -504,10 +501,10 @@ ;;;; miscellaneous utilities -;;; Find the operand or temporary with the specifed Name in the VOP Parse. -;;; If there is no such operand, signal an error. Also error if the operand -;;; kind isn't one of the specified Kinds. If Error-P is NIL, just return NIL -;;; if there is no such operand. +;;; Find the operand or temporary with the specifed Name in the VOP +;;; Parse. If there is no such operand, signal an error. Also error if +;;; 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)) @@ -522,17 +519,17 @@ 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. +;;; 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*) (error "~S is not the name of a defined VOP." name)))) -;;; Return a list of let-forms to parse a tn-ref list into a 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. +;;; 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. (defun access-operands (operands more-operand refs) (declare (list operands)) (collect ((res)) @@ -546,9 +543,9 @@ (res `(,(operand-parse-name more-operand) ,prev)))) (res))) -;;; 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. +;;; 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. (defun ignore-unreferenced-temps (operands) (when operands (operand-parse-temp (car (last operands))))) @@ -567,10 +564,11 @@ ;;;; time specs -;;; Return a time spec describing a time during the evaluation of a VOP, -;;; used to delimit operand and temporary lifetimes. The representation is a -;;; cons whose CAR is the number of the evaluation phase and the CDR is the -;;; sub-phase. The sub-phase is 0 in the :Load and :Save phases. +;;; Return a time spec describing a time during the evaluation of a +;;; VOP, used to delimit operand and temporary lifetimes. The +;;; representation is a cons whose CAR is the number of the evaluation +;;; phase and the CDR is the sub-phase. The sub-phase is 0 in the +;;; :LOAD and :SAVE phases. (defun parse-time-spec (spec) (let ((dspec (if (atom spec) (list spec 0) spec))) (unless (and (= (length dspec) 2) @@ -607,7 +605,7 @@ (declare (type operand-parse temp)) (let ((sc (operand-parse-sc temp)) (offset (operand-parse-offset temp))) - (assert sc) + (aver sc) (setf (aref results index) (if offset (+ (ash offset (1+ sc-bits)) @@ -616,13 +614,14 @@ (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 + ;; 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)))))) (defun compute-ref-ordering (parse) @@ -639,6 +638,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 @@ -649,7 +651,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) @@ -667,14 +671,14 @@ (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 @@ -687,22 +691,25 @@ (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 + ;; 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) @@ -716,11 +723,11 @@ ;;;; generator functions -;;; Return an alist that translates from lists of SCs we can load OP 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) +;;; Return an alist that translates from lists of SCs we can load OP +;;; 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-funs (op load-p) (collect ((funs)) (dolist (sc-name (operand-parse-scs op)) (let* ((sc (meta-sc-or-lose sc-name)) @@ -734,8 +741,8 @@ (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 @@ -758,14 +765,14 @@ sc-name load-p (operand-parse-name op)))))) (funs))) -;;; Return a form to load/save the specified operand when it has a load TN. -;;; For any given SC that we can load from, there must be a unique load -;;; function. If all SCs we can load from have the same 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)) +;;; Return a form to load/save the specified operand when it has a +;;; load TN. For any given SC that we can load from, there must be a +;;; unique load function. If all SCs we can load from have the same +;;; 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-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))) @@ -773,13 +780,13 @@ (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)))) + ,@(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) @@ -792,8 +799,9 @@ (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. +;;; 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)) @@ -834,8 +842,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 @@ -843,10 +851,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)) @@ -854,26 +862,27 @@ `(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)))))) -;;; 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. If we are inheriting a -;;; VOP, we default attributes to the inherited operand of the same name. -(defun parse-operands (parse specs kind) +;;; 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. +;;; If we are inheriting a VOP, we default attributes to the inherited +;;; operand of the same name. +(defun !parse-vop-operands (parse specs kind) (declare (list specs) (type (member :argument :result) kind)) (let ((num -1) @@ -920,21 +929,21 @@ (let ((value (second key))) (case (first key) (:scs - (check-type value list) + (aver (typep value 'list)) (setf (operand-parse-scs res) (remove-duplicates value))) (:load-tn - (check-type value symbol) + (aver (typep value 'symbol)) (setf (operand-parse-load-tn res) value)) (:load-if (setf (operand-parse-load res) value)) (:more - (check-type value boolean) + (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 - (check-type value symbol) + (aver (typep value 'symbol)) (setf (operand-parse-target res) value)) (:from (unless (eq kind :result) @@ -955,8 +964,8 @@ (error "cannot specify :LOAD-IF in a :MORE operand"))))) (values (the list (operands)) more)))) -;;; Parse a temporary specification, entering the Operand-Parse structures -;;; in the Parse structure. +;;; 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)) @@ -988,13 +997,13 @@ (vop-spec-arg opt 'symbol 1 nil))) (:offset (let ((offset (eval (second opt)))) - (check-type offset unsigned-byte) + (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... + ;; backward compatibility... (:scs (let ((scs (vop-spec-arg opt 'list 1 nil))) (unless (= (length scs) 1) @@ -1019,7 +1028,8 @@ :key #'operand-parse-name)))))) (values)) -;;; Top-level parse function. Clobber Parse to represent the specified options. +;;; 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) @@ -1028,12 +1038,12 @@ (case (first spec) (:args (multiple-value-bind (fixed more) - (parse-operands parse (rest spec) :argument) + (!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-operands parse (rest spec) :result) + (!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)) @@ -1077,16 +1087,21 @@ (setf (vop-parse-note parse) (vop-spec-arg spec '(or string null)))) (:arg-types (setf (vop-parse-arg-types parse) - (parse-operand-types (rest spec) t))) + (!parse-vop-operand-types (rest spec) t))) (:result-types (setf (vop-parse-result-types parse) - (parse-operand-types (rest spec) nil))) + (!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-policy parse) (vop-spec-arg spec 'policies))) + (setf (vop-parse-ltn-policy parse) + (vop-spec-arg spec 'ltn-policy))) (:save-p (setf (vop-parse-save-p parse) (vop-spec-arg spec @@ -1095,16 +1110,16 @@ (error "unknown option specifier: ~S" (first spec))))) (values)) -;;;; make costs and restrictions +;;;; making costs and restrictions ;;; Given an operand, returns two values: -;;; 1. A SC-vector of the cost for the operand being in that SC, including both -;;; the costs for move functions and coercion VOPs. -;;; 2. A SC-vector holding the SC that we load into, for any SC that we can -;;; directly load from. +;;; 1. A SC-vector of the cost for the operand being in that SC, +;;; including both the costs for move functions and coercion VOPs. +;;; 2. A SC-vector holding the SC that we load into, for any SC +;;; that we can directly load from. ;;; -;;; In both vectors, unused entries are NIL. Load-P specifies the direction: -;;; if true, we are loading, if false we are saving. +;;; In both vectors, unused entries are NIL. LOAD-P specifies the +;;; direction: if true, we are loading, if false we are saving. (defun compute-loading-costs (op load-p) (declare (type operand-parse op)) (let ((scs (operand-parse-scs op)) @@ -1151,9 +1166,9 @@ (make-array sc-number-limit :initial-element 0)) (defparameter *no-loads* - (make-array sc-number-limit :initial-element 't)) + (make-array sc-number-limit :initial-element t)) -;;; Pick off the case of operands with no restrictions. +;;; Pick off the case of operands with no restrictions. (defun compute-loading-costs-if-any (op load-p) (declare (type operand-parse op)) (if (operand-parse-scs op) @@ -1195,9 +1210,9 @@ ;;;; operand checking and stuff -;;; Given a list of arg/result restrictions, check for valid syntax and -;;; convert to canonical form. -(defun parse-operand-types (specs args-p) +;;; Given a list of arg/result restrictions, check for valid syntax +;;; and convert to canonical form. +(defun !parse-vop-operand-types (specs args-p) (declare (list specs)) (labels ((parse-operand-type (spec) (cond ((eq spec '*) spec) @@ -1244,16 +1259,16 @@ (mapcar #'parse-operand-type specs))) ;;; 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. +;;; primitive-type restriction. :CONSTANT operands have already been +;;; filtered out, so only :OR and * restrictions are left. ;;; -;;; We check that every representation allowed by the type can be directly -;;; loaded into some SC in the restriction, and that the type allows every SC -;;; in the restriction. With *, we require that T satisfy the first test, and -;;; omit the second. +;;; We check that every representation allowed by the type can be +;;; directly loaded into some SC in the restriction, and that the type +;;; allows every SC in the restriction. With *, we require that T +;;; satisfy the first test, and omit the second. (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))) + (let ((ptypes (if (eq type '*) (list t) (rest type))) (scs (operand-parse-scs op))) (when scs (multiple-value-bind (costs load-scs) (compute-loading-costs op load-p) @@ -1295,12 +1310,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 @@ -1310,19 +1325,19 @@ (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. -(defun grovel-operands (parse) +(defun !grovel-vop-operands (parse) (declare (type vop-parse parse)) (setf (vop-parse-operands parse) @@ -1350,23 +1365,22 @@ ;;;; 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 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) +;;; 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 +;;; VOP is conditional, causing IR1 conversion to ensure that a call +;;; to the translated is always used in a predicate position. +(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 @@ -1378,9 +1392,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))) @@ -1391,10 +1405,10 @@ (make-list (+ (length ops) (if more-ops 1 0)) :initial-element '*) types)) -;;; Return a list of forms to use as keyword args to Make-VOP-Info for -;;; setting up the template argument and result types. Here we make an initial -;;; dummy Template-Type, since it is awkward to compute the type until the -;;; template has been made. +;;; Return a list of forms to use as &KEY args to MAKE-VOP-INFO for +;;; setting up the template argument and result types. Here we make an +;;; initial dummy TEMPLATE-TYPE, since it is awkward to compute the +;;; 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) @@ -1410,8 +1424,7 @@ (more-result (when more-results (car (last all-results)))) (conditional (vop-parse-conditional-p parse))) - `( - :type (specifier-type '(function () nil)) + `(: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 @@ -1426,13 +1439,14 @@ (defparameter *slot-inherit-alist* '((:generator-function . vop-info-generator-function)))) -;;; 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 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 the Form so that the slot is recomputed. +;;; 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 +;;; 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 +;;; the FORM so that the slot is recomputed. (defmacro inherit-vop-info (slot parse test form) `(if (and ,parse ,test) (list ,slot `(,',(or (cdr (assoc slot *slot-inherit-alist*)) @@ -1453,16 +1467,16 @@ (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)) - :policy ',(vop-parse-policy parse) + :ltn-policy ',(vop-parse-ltn-policy parse) :save-p ',(vop-parse-save-p parse) :move-args ',(vop-parse-move-args parse) :effects (vop-attributes ,@(vop-parse-effects parse)) @@ -1476,197 +1490,204 @@ (make-generator-function parse))) :variant (list ,@variant)))) -;;; 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. +;;; Define the symbol NAME to be a Virtual OPeration in the compiler. +;;; If specified, INHERITS is the name of a VOP that we default +;;; unspecified information from. Each SPEC is a list beginning with a +;;; keyword indicating the interpretation of the other forms in the +;;; SPEC: +;;; +;;; :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. +;;; +;;; :Load-TN Load-Name +;;; Load-Name is bound to the load TN allocated for this operand, +;;; or to NIL if no load TN was allocated. +;;; +;;; :Load-If EXPRESSION +;;; Controls whether automatic operand loading is done. +;;; EXPRESSION is evaluated with the fixed operand TNs bound. +;;; If EXPRESSION is true,then loading is done and the variable +;;; is bound to the load TN in the generator body. Otherwise, +;;; loading is not done, and the variable is bound to the actual +;;; operand. +;;; +;;; :More T-or-NIL +;;; If specified, Name is bound to the TN-Ref for the first +;;; argument or result following the fixed arguments or results. +;;; A :MORE operand must appear last, and cannot be targeted or +;;; restricted. +;;; +;;; :Target Operand +;;; This operand is targeted to the named operand, indicating a +;;; desire to pack in the same location. Not legal for results. +;;; +;;; :From Time-Spec +;;; :To Time-Spec +;;; Specify the beginning or end of the operand's lifetime. +;;; :FROM can only be used with results, and :TO only with +;;; arguments. The default for the N'th argument/result is +;;; (:ARGUMENT N)/(:RESULT N). These options are necessary +;;; primarily when operands are read or written out of order. +;;; +;;; :Conditional +;;; This is used in place of :RESULTS with conditional branch VOPs. +;;; There are no result values: the result is a transfer of control. +;;; The target label is passed as the first :INFO arg. The second +;;; :INFO arg is true if the sense of the test should be negated. +;;; A side-effect is to set the PREDICATE attribute for functions +;;; in the :TRANSLATE option. +;;; +;;; :Temporary ({Key Value}*) Name* +;;; Allocate a temporary TN for each Name, binding that variable to +;;; the TN 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. +;;; +;;; :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* +;;; 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 +;;; translation of the VOP. An ASSEMBLE form is wrapped around +;;; the body, so code may be emitted by using the local INST macro. +;;; During the evaluation of the body, the names of the operands +;;; and temporaries are bound to the actual TNs. +;;; +;;; :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* +;;; 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 +;;; cannot be specified for VOPS that are the direct translation +;;; for a function (specified by :Translate). +;;; +;;; :Ignore Name* +;;; Causes the named variables to be declared IGNORE in the +;;; generator body. +;;; +;;; :Variant Thing* +;;; :Variant-Vars Name* +;;; These options provide a way to parameterize families of VOPs +;;; 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 +;;; Specifies the cost of this VOP, overriding the cost of any +;;; inherited generator. +;;; +;;; :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. +;;; +;;; :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} +;;; 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. +;;; +;;; :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} +;;; Indicates how a VOP wants live registers saved. +;;; +;;; :Move-Args {NIL | :Full-Call | :Local-Call | :Known-Return} +;;; Indicates if and how the more args should be moved into a +;;; different frame. (def!macro define-vop ((name &optional inherits) &rest specs) - #!+sb-doc - "Define-VOP (Name [Inherits]) Spec* - Define the symbol Name to be a Virtual OPeration in the compiler. If - specified, Inherits is the name of a VOP that we default unspecified - information from. Each Spec is a list beginning with a keyword indicating - the interpretation of the other forms in the Spec: - - :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. - - :Load-TN Load-Name - Load-Name is bound to the load TN allocated for this operand, or to - NIL if no load TN was allocated. - - :Load-If Expression - Controls whether automatic operand loading is done. Expression is - evaluated with the fixed operand TNs bound. If Expression is true, - then loading is done and the variable is bound to the load TN in - the generator body. Otherwise, loading is not done, and the variable - is bound to the actual operand. - - :More T-or-NIL - If specified, Name is bound to the TN-Ref for the first argument or - result following the fixed arguments or results. A more operand must - appear last, and cannot be targeted or restricted. - - :Target Operand - This operand is targeted to the named operand, indicating a desire to - pack in the same location. Not legal for results. - - :From Time-Spec - :To Time-Spec - Specify the beginning or end of the operand's lifetime. :From can - only be used with results, and :To only with arguments. The default - for the N'th argument/result is (:ARGUMENT N)/(:RESULT N). These - options are necessary primarily when operands are read or written out - of order. - - :Conditional - This is used in place of :RESULTS with conditional branch VOPs. There - are no result values: the result is a transfer of control. The target - label is passed as the first :INFO arg. The second :INFO arg is true if - the sense of the test should be negated. A side-effect is to set the - PREDICATE attribute for functions in the :TRANSLATE option. - - :Temporary ({Key Value}*) Name* - Allocate a temporary TN for each Name, binding that variable to the TN - 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. - - :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* - 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 translation of the VOP. An Assemble - form is wrapped around the body, so code may be emitted by using the - local Inst macro. During the evaluation of the body, the names of the - operands and temporaries are bound to the actual TNs. - - :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* - 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 cannot be specified for VOPS that are - the direct translation for a function (specified by :Translate). - - :Ignore Name* - Causes the named variables to be declared IGNORE in the generator body. - - :Variant Thing* - :Variant-Vars Name* - These options provide a way to parameterize families of VOPs 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 - Specifies the cost of this VOP, overriding the cost of any inherited - generator. - - :Note {String | NIL} - A short noun-like phrase describing what this VOP \"does\", i.e. the - implementation strategy. If supplied, efficency notes will be generated - when type uncertainty prevents :TRANSLATE from working. NIL inhibits any - efficency 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. - - :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} - 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. - - :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} - Indicates how a VOP wants live registers saved. - - :Move-Args {NIL | :Full-Call | :Local-Call | :Known-Return} - Indicates if and how the more args should be moved into a different - frame." - (check-type name symbol) - - (let* ((iparse (when inherits - (vop-parse-or-lose inherits))) + (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 iparse) + (copy-vop-parse inherited-parse) (make-vop-parse))) (n-res (gensym))) (setf (vop-parse-name parse) name) (setf (vop-parse-inherits parse) inherits) (parse-define-vop parse specs) - (grovel-operands parse) + (!grovel-vop-operands parse) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (setf (gethash ',name *backend-parsed-vops*) ',parse)) - (let ((,n-res ,(set-up-vop-info iparse 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-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* 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 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 that will be made the tail of the list. If -;;; it is constant NIL, then we don't bother to set the tail. +;;; 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 +;;; 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 +;;; 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) (collect ((forms) (binds)) @@ -1689,11 +1710,11 @@ (values (forms) (binds) n-head)))) +;;; Emit-Template Node Block Template Args Results [Info] +;;; +;;; 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) - #!+sb-doc - "Emit-Template Node Block Template Args Results [Info] - Call the emit function for Template, linking the result in at the end of - Block." (let ((n-first (gensym)) (n-last (gensym))) (once-only ((n-node node) @@ -1705,20 +1726,21 @@ ,@(when info `(,info))) (insert-vop-sequence ,n-first ,n-last ,n-block nil))))) +;;; 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 +;;; 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 +;;; 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. (defmacro vop (name node block &rest operands) - #!+sb-doc - "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 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 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." (let* ((parse (vop-parse-or-lose name)) (arg-count (length (vop-parse-args parse))) (result-count (length (vop-parse-results parse))) @@ -1731,14 +1753,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))) @@ -1760,22 +1782,23 @@ `((list ,@(ivars))))) (values))))))) +;;; VOP* Name Node Block (Arg* More-Args) (Result* More-Results) Info* +;;; +;;; 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. +;;; +;;; The Arguments 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 +;;; initialized. +;;; +;;; As with VOP, the Info forms are evaluated and passed as codegen +;;; info arguments. (defmacro vop* (name node block args results &rest info) - #!+sb-doc - "VOP* Name Node Block (Arg* More-Args) (Result* More-Results) Info* - Like VOP, but allows for emission of templates with arbitrary numbers of - arguments, and for emission of templates using already-created TN-Ref lists. - - The Arguments 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 initialized. - - As with VOP, the Info forms are evaluated and passed as codegen info - arguments." - (check-type args cons) - (check-type results cons) + (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))) @@ -1793,13 +1816,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)) @@ -1814,13 +1837,14 @@ ;;;; miscellaneous macros +;;; SC-Case TN {({(SC-Name*) | SC-Name | T} Form*)}* +;;; +;;; Case off of TN's SC. The first clause containing TN's SC is +;;; evaluated, returning the values of the last form. A clause +;;; 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) - #!+sb-doc - "SC-Case TN {({(SC-Name*) | SC-Name | T} Form*)}* - Case off of TN's SC. The first clause containing TN's SC is evaluated, - returning the values of the last form. A clause 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." (let ((n-sc (gensym)) (n-tn (gensym))) (collect ((clauses)) @@ -1837,9 +1861,9 @@ (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)))))) @@ -1847,30 +1871,25 @@ (,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) - #!+sb-doc - "SC-Is TN SC* - Returns true if TNs SC is any of the named SCs, false otherwise." (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. (defmacro do-ir2-blocks ((block-var component &optional result) &body forms) - #!+sb-doc - "Do-IR2-Blocks (Block-Var Component [Result]) Form* - Iterate over the IR2 blocks in component, in emission order." `(do ((,block-var (block-info (component-head ,component)) (ir2-block-next ,block-var))) ((null ,block-var) ,result) ,@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 +;;; containing the location. (defmacro do-live-tns ((tn-var live block &optional result) &body body) - #!+sb-doc - "DO-LIVE-TNS (TN-Var Live Block [Result]) Form* - Iterate over all the TNs live at some point, with the live set represented by - a local conflicts bit-vector and the IR2-Block containing the location." (let ((n-conf (gensym)) (n-bod (gensym)) (i (gensym)) @@ -1903,21 +1922,17 @@ (when (and ,tn-var (not (eq ,tn-var :more))) (,n-bod ,tn-var))))))))))) -(defmacro do-environment-ir2-blocks ((block-var env &optional result) - &body body) - #!+sb-doc - "DO-ENVIRONMENT-IR2-BLOCKS (Block-Var Env [Result]) Form* - Iterate over all the IR2 blocks in the environment Env, in emit order." - (once-only ((n-env env)) - (once-only ((n-first `(node-block - (lambda-bind - (environment-function ,n-env))))) +;;; Iterate over all the IR2 blocks in PHYSENV, in emit order. +(defmacro do-physenv-ir2-blocks ((block-var physenv &optional result) + &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-environment ,block-var) ,n-env))) + (not (eq (ir2-block-physenv ,block-var) ,n-physenv))) ,result) ,@body)))))