;;;
;;; We enter the basic structure at meta-compile time, and then fill
;;; in the missing slots at load time.
-(defmacro define-storage-base (name kind &key size)
+(defmacro define-storage-base (name kind &key size (size-increment size)
+ (size-alignment 1))
(declare (type symbol name))
(declare (type (member :finite :unbounded :non-packed) kind))
(error "A size specification is meaningless in a ~S SB." kind)))
((:finite :unbounded)
(unless size (error "Size is not specified in a ~S SB." kind))
- (aver (typep size 'unsigned-byte))))
+ (aver (typep size 'unsigned-byte))
+ (aver (= 1 (logcount size-alignment)))
+ (aver (not (logtest size (1- size-alignment))))
+ (aver (not (logtest size-increment (1- size-alignment))))))
(let ((res (if (eq kind :non-packed)
(make-sb :name name :kind kind)
- (make-finite-sb :name name :kind kind :size size))))
+ (make-finite-sb :name name :kind kind :size size
+ :size-increment size-increment
+ :size-alignment size-alignment))))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(/show0 "about to SETF GETHASH META-SB-NAMES in DEFINE-STORAGE-BASE")
(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
(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.
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))
(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)
(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
(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)))
\f
;;;; generator functions
(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
((symbolp type)
``(:or ,(primitive-type-or-lose ',type)))
(t
- (ecase (first type)
+ (ecase (car type)
(:or
``(:or ,,@(mapcar (lambda (type)
`(primitive-type-or-lose ',type))
(rest type))))
(:constant
``(:constant ,#'(lambda (x)
- (typep x ',(second type)))
+ ;; Can't handle SATISFIES during XC
+ ,(if (and (consp (second type))
+ (eq (caadr type) 'satisfies))
+ `(,(cadadr type) x)
+ `(sb!xc:typep x ',(second type))))
,',(second type)))))))
(defun specify-operand-types (types ops more-ops)
`(: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)))))
\f
;;; :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.
;;; (: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
;;; 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
;;; :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.
;;; 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).
;;;
;;; :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.
;;; 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*
;;;
;;; 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)
projects / sbcl.git / blobdiff