X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmeta-vmdef.lisp;h=1b8c5ae702b7a5624e3974f1200794c2f5c66c18;hb=29a9ccc860532b32c566aec095f570e999a9c52c;hp=c21db652bcc821e6a8ebbd6520b92a51e69a18e1;hpb=2c6b90e36a7c0377cd79625eb6c94d580f98cb93;p=sbcl.git diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp index c21db65..1b8c5ae 100644 --- a/src/compiler/meta-vmdef.lisp +++ b/src/compiler/meta-vmdef.lisp @@ -126,7 +126,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 +136,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 +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) @@ -176,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) @@ -205,9 +205,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 +216,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 @@ -274,7 +274,7 @@ (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)) @@ -282,9 +282,9 @@ (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 @@ -331,15 +331,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))) @@ -458,7 +458,7 @@ ;; name of the operand (which we bind to the TN) (name nil :type symbol) ;; the way this operand is used: - (kind (required-argument) + (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. @@ -665,14 +665,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 @@ -721,7 +721,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,8 +735,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 @@ -765,8 +765,8 @@ ;;; 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))) @@ -774,13 +774,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) @@ -836,8 +836,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 +845,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,20 +856,20 @@ `(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 @@ -1022,7 +1022,7 @@ :key #'operand-parse-name)))))) (values)) -;;; the top-level parse function: clobber PARSE to represent the +;;; 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)) @@ -1304,12 +1304,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,12 +1319,12 @@ (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)) @@ -1364,18 +1364,17 @@ ;;; 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 +1386,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))) @@ -1419,8 +1418,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 @@ -1435,14 +1433,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*)) @@ -1463,13 +1461,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) @@ -1486,10 +1484,11 @@ (make-generator-function parse))) :variant (list ,@variant)))) -;;; 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: +;;; 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}*)}* @@ -1607,9 +1606,9 @@ ;;; ;;; :Note {String | NIL} ;;; A short noun-like phrase describing what this VOP "does", i.e. -;;; the implementation strategy. If supplied, efficency notes will +;;; the implementation strategy. If supplied, efficiency notes will ;;; be generated when type uncertainty prevents :TRANSLATE from -;;; working. NIL inhibits any efficency note. +;;; working. NIL inhibits any efficiency note. ;;; ;;; :Arg-Types {* | PType | (:OR PType*) | (:CONSTANT Type)}* ;;; :Result-Types {* | PType | (:OR PType*)}* @@ -1669,7 +1668,7 @@ (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 @@ -1748,7 +1747,7 @@ (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) @@ -1811,7 +1810,7 @@ (<= (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) @@ -1856,9 +1855,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)))))) @@ -1869,8 +1868,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. @@ -1917,19 +1916,17 @@ (when (and ,tn-var (not (eq ,tn-var :more))) (,n-bod ,tn-var))))))))))) -;;; Iterate over all the IR2 blocks in the environment Env, in emit order. -(defmacro do-environment-ir2-blocks ((block-var env &optional result) - &body body) - (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)))))