X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmeta-vmdef.lisp;h=e29e5ba8f514f9d1b15bf1afd568ca9ca0aa86f2;hb=8900bab84deb87a7e2a039db7ecb224bcf871708;hp=41270d2967fe8b014f31bcf81a8f6ca54cde16a8;hpb=de01f09401517c1a96de3faeac585e46895940ec;p=sbcl.git diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp index 41270d2..e29e5ba 100644 --- a/src/compiler/meta-vmdef.lisp +++ b/src/compiler/meta-vmdef.lisp @@ -389,7 +389,9 @@ (operands nil :type list) ;; names of variables that should be declared IGNORE (ignores () :type list) - ;; true if this is a :CONDITIONAL VOP + ;; true if this is a :CONDITIONAL VOP. T if a branchful VOP, + ;; a list of condition descriptor otherwise. See $ARCH/pred.lisp + ;; for more information. (conditional-p nil) ;; argument and result primitive types. These are pulled out of the ;; operands, since we often want to change them without respecifying @@ -415,8 +417,8 @@ (note nil :type (or string null)) ;; a list of the names of the Effects and Affected attributes for ;; this VOP - (effects '(any) :type list) - (affected '(any) :type list) + (effects '#1=(any) :type list) + (affected '#1# :type list) ;; a list of the names of functions this VOP is a translation of and ;; the policy that allows this translation to be done. :FAST is a ;; safe default, since it isn't a safe policy. @@ -612,16 +614,14 @@ 1) (ash (meta-sc-number-or-lose sc) 1)))) (incf index)) - ;; KLUDGE: As in the other COERCEs wrapped around with - ;; MAKE-SPECIALIZABLE-ARRAY results in COMPUTE-REF-ORDERING, - ;; this coercion could be removed by a sufficiently smart - ;; compiler, but I dunno whether Python is that smart. It - ;; would be good to check this and help it if it's not smart - ;; enough to remove it for itself. However, it's probably not - ;; urgent, since the overhead of an extra no-op conversion is - ;; unlikely to be large compared to consing and corresponding - ;; GC. -- WHN ca. 19990701 - `(coerce ,results '(specializable-vector ,element-type)))))) + ;; KLUDGE: The load-time MAKE-ARRAY here is an artifact of our + ;; cross-compilation strategy, and the conservative + ;; assumptions we are forced to make on which specialized + ;; arrays exist on the host lisp that the cross-compiler is + ;; running on. (We used to use COERCE here, but that caused + ;; SUBTYPEP calls too early in cold-init for comfort). -- + ;; CSR, 2009-10-30 + `(make-array ,(length results) :element-type '(specializable ,element-type) :initial-contents ',results))))) (defun compute-ref-ordering (parse) (let* ((num-args (+ (length (vop-parse-args parse)) @@ -638,7 +638,7 @@ (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 + ;; EMIT-VOP, and this is currently maintained by ;; hand. -- WHN 2002-01-30, paraphrasing APD (targets (+ (* index max-vop-tn-refs) (ecase (operand-parse-kind target) @@ -669,16 +669,16 @@ (incf index) (refs (cons (cons born t) index)))) (incf index))) - (let* ((sorted (sort (refs) - (lambda (x y) - (let ((x-time (car x)) - (y-time (car y))) - (if (time-spec-order x-time y-time) - (if (time-spec-order y-time x-time) - (and (not (cdr x)) (cdr y)) - nil) - t))) - :key #'car)) + (let* ((sorted (stable-sort (refs) + (lambda (x y) + (let ((x-time (car x)) + (y-time (car y))) + (if (time-spec-order x-time y-time) + (if (time-spec-order y-time x-time) + (and (not (cdr x)) (cdr y)) + nil) + t))) + :key #'car)) ;; :REF-ORDERING element type ;; ;; KLUDGE: was (MOD #.MAX-VOP-TN-REFS), which is still right @@ -698,34 +698,18 @@ (incf index))) `(:num-args ,num-args :num-results ,num-results - ;; KLUDGE: The (COERCE .. (SPECIALIZABLE-VECTOR ..)) wrapper - ;; here around the result returned by - ;; MAKE-SPECIALIZABLE-ARRAY above was of course added to - ;; help with cross-compilation. "A sufficiently smart - ;; compiler" should be able to optimize all this away in the - ;; final target Lisp, leaving a single MAKE-ARRAY with no - ;; subsequent coercion. However, I don't know whether Python - ;; is that smart. (Can it figure out the return type of - ;; MAKE-ARRAY? Does it know that COERCE can be optimized - ;; away if the input type is known to be the same as the - ;; COERCEd-to type?) At some point it would be good to test - ;; to see whether this construct is in fact causing run-time - ;; overhead, and fix it if so. (Some declarations of the - ;; types returned by MAKE-ARRAY might be enough to fix it.) - ;; However, it's probably not urgent to fix this, since it's - ;; hard to imagine that any overhead caused by calling - ;; COERCE and letting it decide to bail out could be large - ;; compared to the cost of consing and GCing the vectors in - ;; the first place. -- WHN ca. 19990701 - :ref-ordering (coerce ',ordering - '(specializable-vector ,oe-type)) + ;; KLUDGE: see the comment regarding MAKE-ARRAY in + ;; COMPUTE-TEMPORARIES-DESCRIPTION. -- CSR, 2009-10-30 + :ref-ordering (make-array ,(length ordering) + :initial-contents ',ordering + :element-type '(specializable ,oe-type)) ,@(when (targets) - `(:targets (coerce ',(targets) - '(specializable-vector ,te-type))))))))) + `(:targets (make-array ,(length (targets)) + :initial-contents ',(targets) + :element-type '(specializable ,te-type))))))))) (defun make-emit-function-and-friends (parse) - `(:emit-function #'emit-generic-vop - :temps ,(compute-temporaries-description parse) + `(:temps ,(compute-temporaries-description parse) ,@(compute-ref-ordering parse))) ;;;; generator functions @@ -1083,7 +1067,7 @@ (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)) + (setf (vop-parse-conditional-p parse) (or (rest spec) t))) (:temporary (parse-temporary spec parse)) (:generator @@ -1430,7 +1414,7 @@ (rest type)))) (:constant ``(:constant ,#'(lambda (x) - (typep x ',(second type))) + (sb!xc:typep x ',(second type))) ,',(second type))))))) (defun specify-operand-types (types ops more-ops) @@ -1460,9 +1444,12 @@ `(:type (specifier-type '(function () nil)) :arg-types (list ,@(mapcar #'make-operand-type args)) :more-args-type ,(when more-args (make-operand-type more-arg)) - :result-types ,(if conditional - :conditional - `(list ,@(mapcar #'make-operand-type results))) + :result-types ,(cond ((eq conditional t) + :conditional) + (conditional + `'(:conditional . ,conditional)) + (t + `(list ,@(mapcar #'make-operand-type results)))) :more-results-type ,(when more-results (make-operand-type more-result))))) @@ -1549,7 +1536,7 @@ ;;; :LOAD-IF EXPRESSION ;;; Controls whether automatic operand loading is done. ;;; EXPRESSION is evaluated with the fixed operand TNs bound. -;;; If EXPRESSION is true,then loading is done and the variable +;;; If EXPRESSION is true, then loading is done and the variable ;;; is bound to the load TN in the generator body. Otherwise, ;;; loading is not done, and the variable is bound to the actual ;;; operand. @@ -1572,7 +1559,7 @@ ;;; (:ARGUMENT N)/(:RESULT N). These options are necessary ;;; primarily when operands are read or written out of order. ;;; -;;; :CONDITIONAL +;;; :CONDITIONAL [Condition-descriptor+] ;;; This is used in place of :RESULTS with conditional branch VOPs. ;;; There are no result values: the result is a transfer of control. ;;; The target label is passed as the first :INFO arg. The second @@ -1580,6 +1567,10 @@ ;;; A side effect is to set the PREDICATE attribute for functions ;;; in the :TRANSLATE option. ;;; +;;; If some condition descriptors are provided, this is a flag-setting +;;; VOP. Descriptors are interpreted in an architecture-dependent +;;; manner. See the BRANCH-IF VOP in $ARCH/pred.lisp. +;;; ;;; :TEMPORARY ({Key Value}*) Name* ;;; Allocate a temporary TN for each Name, binding that variable to ;;; the TN within the body of the generators. In addition to :TARGET @@ -1590,7 +1581,7 @@ ;;; :OFFSET SB-Offset ;;; Force the temporary to be allocated in the specified SC ;;; with the specified offset. Offset is evaluated at -;;; macroexpand time. If Offset is emitted, the register +;;; macroexpand time. If Offset is omitted, the register ;;; allocator chooses a free location in SC. If both SC and ;;; Offset are omitted, then the temporary is packed according ;;; to its primitive type. @@ -1600,7 +1591,7 @@ ;;; Similar to the argument/result option, this specifies the ;;; start and end of the temporaries' lives. The defaults are ;;; :LOAD and :SAVE, i.e. the duration of the VOP. The other -;;; intervening phases are :ARGUMENT,:EVAL and :RESULT. +;;; intervening phases are :ARGUMENT, :EVAL and :RESULT. ;;; Non-zero sub-phases can be specified by a list, e.g. by ;;; default the second argument's life ends at (:ARGUMENT 1). ;;; @@ -1682,7 +1673,7 @@ ;;; :MOVE-ARGS {NIL | :FULL-CALL | :LOCAL-CALL | :KNOWN-RETURN} ;;; Indicates if and how the more args should be moved into a ;;; different frame. -(def!macro define-vop ((name &optional inherits) &rest specs) +(def!macro define-vop ((name &optional inherits) &body specs) (declare (type symbol name)) ;; Parse the syntax into a VOP-PARSE structure, and then expand into ;; code that creates the appropriate VOP-INFO structure at load time. @@ -1750,16 +1741,8 @@ ;;; Call the emit function for TEMPLATE, linking the result in at the ;;; end of BLOCK. (defmacro emit-template (node block template args results &optional info) - (let ((n-first (gensym)) - (n-last (gensym))) - (once-only ((n-node node) - (n-block block) - (n-template template)) - `(multiple-value-bind (,n-first ,n-last) - (funcall (template-emit-function ,n-template) - ,n-node ,n-block ,n-template ,args ,results - ,@(when info `(,info))) - (insert-vop-sequence ,n-first ,n-last ,n-block nil))))) + `(emit-and-insert-vop ,node ,block ,template ,args ,results nil + ,@(when info `(,info)))) ;;; VOP Name Node Block Arg* Info* Result* ;;; @@ -1925,37 +1908,34 @@ ;;; represented by a local conflicts bit-vector and the IR2-BLOCK ;;; containing the location. (defmacro do-live-tns ((tn-var live block &optional result) &body body) - (let ((n-conf (gensym)) - (n-bod (gensym)) - (i (gensym)) - (ltns (gensym))) + (with-unique-names (conf bod i ltns) (once-only ((n-live live) (n-block block)) `(block nil - (flet ((,n-bod (,tn-var) ,@body)) + (flet ((,bod (,tn-var) ,@body)) ;; Do component-live TNs. (dolist (,tn-var (ir2-component-component-tns (component-info (block-component (ir2-block-block ,n-block))))) - (,n-bod ,tn-var)) + (,bod ,tn-var)) (let ((,ltns (ir2-block-local-tns ,n-block))) ;; Do TNs always-live in this block and live :MORE TNs. - (do ((,n-conf (ir2-block-global-tns ,n-block) - (global-conflicts-next-blockwise ,n-conf))) - ((null ,n-conf)) - (when (or (eq (global-conflicts-kind ,n-conf) :live) - (let ((,i (global-conflicts-number ,n-conf))) + (do ((,conf (ir2-block-global-tns ,n-block) + (global-conflicts-next-blockwise ,conf))) + ((null ,conf)) + (when (or (eq (global-conflicts-kind ,conf) :live) + (let ((,i (global-conflicts-number ,conf))) (and (eq (svref ,ltns ,i) :more) (not (zerop (sbit ,n-live ,i)))))) - (,n-bod (global-conflicts-tn ,n-conf)))) + (,bod (global-conflicts-tn ,conf)))) ;; Do TNs locally live in the designated live set. (dotimes (,i (ir2-block-local-tn-count ,n-block) ,result) (unless (zerop (sbit ,n-live ,i)) (let ((,tn-var (svref ,ltns ,i))) (when (and ,tn-var (not (eq ,tn-var :more))) - (,n-bod ,tn-var))))))))))) + (,bod ,tn-var))))))))))) ;;; Iterate over all the IR2 blocks in PHYSENV, in emit order. (defmacro do-physenv-ir2-blocks ((block-var physenv &optional result)