1 ;;;; This file contains the implementation-independent facilities used
2 ;;;; for defining the compiler's interface to the VM in a given
3 ;;;; implementation that are needed at meta-compile time. They are
4 ;;;; separated out from vmdef.lisp so that they can be compiled and
5 ;;;; loaded without trashing the running compiler.
7 ;;;; FIXME: The "trashing the running [CMU CL] compiler" motivation no
8 ;;;; longer makes sense in SBCL, since we can cross-compile cleanly.
10 ;;;; This software is part of the SBCL system. See the README file for
11 ;;;; more information.
13 ;;;; This software is derived from the CMU CL system, which was
14 ;;;; written at Carnegie Mellon University and released into the
15 ;;;; public domain. The software is in the public domain and is
16 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
17 ;;;; files for more information.
21 ;;;; storage class and storage base definition
23 ;;; Define a storage base having the specified NAME. KIND may be :FINITE,
24 ;;; :UNBOUNDED or :NON-PACKED. The following keywords are legal:
25 ;;; :SIZE specifies the number of locations in a :FINITE SB or
26 ;;; the initial size of an :UNBOUNDED SB.
28 ;;; We enter the basic structure at meta-compile time, and then fill
29 ;;; in the missing slots at load time.
30 (defmacro define-storage-base (name kind &key size)
32 (declare (type symbol name))
33 (declare (type (member :finite :unbounded :non-packed) kind))
35 ;; SIZE is either mandatory or forbidden.
39 (error "A size specification is meaningless in a ~S SB." kind)))
41 (unless size (error "Size is not specified in a ~S SB." kind))
42 (aver (typep size 'unsigned-byte))))
44 (let ((res (if (eq kind :non-packed)
45 (make-sb :name name :kind kind)
46 (make-finite-sb :name name :kind kind :size size))))
48 (eval-when (:compile-toplevel :load-toplevel :execute)
49 (/show0 "about to SETF GETHASH META-SB-NAMES in DEFINE-STORAGE-BASE")
50 (setf (gethash ',name *backend-meta-sb-names*)
52 (/show0 "about to SETF GETHASH SB-NAMES in DEFINE-STORAGE-BASE")
53 ,(if (eq kind :non-packed)
54 `(setf (gethash ',name *backend-sb-names*)
56 `(let ((res (copy-finite-sb ',res)))
57 (/show0 "not :NON-PACKED, i.e. hairy case")
58 (setf (finite-sb-always-live res)
61 #-(or sb-xc sb-xc-host) #*
62 ;; The cross-compiler isn't very good
63 ;; at dumping specialized arrays; we
64 ;; work around that by postponing
65 ;; generation of the specialized
66 ;; array 'til runtime.
67 #+(or sb-xc sb-xc-host)
68 (make-array 0 :element-type 'bit)))
69 (/show0 "doing second SETF")
70 (setf (finite-sb-conflicts res)
71 (make-array ',size :initial-element '#()))
72 (/show0 "doing third SETF")
73 (setf (finite-sb-live-tns res)
74 (make-array ',size :initial-element nil))
75 (/show0 "doing fourth SETF")
76 (setf (finite-sb-always-live-count res)
77 (make-array ',size :initial-element 0))
78 (/show0 "doing fifth and final SETF")
79 (setf (gethash ',name *backend-sb-names*)
82 (/show0 "about to put SB onto/into SB-LIST")
83 (setf *backend-sb-list*
84 (cons (sb-or-lose ',name)
85 (remove ',name *backend-sb-list* :key #'sb-name)))
86 (/show0 "finished with DEFINE-STORAGE-BASE expansion")
89 ;;; Define a storage class NAME that uses the named Storage-Base.
90 ;;; NUMBER is a small, non-negative integer that is used as an alias.
91 ;;; The following keywords are defined:
93 ;;; :ELEMENT-SIZE Size
94 ;;; The size of objects in this SC in whatever units the SB uses.
95 ;;; This defaults to 1.
98 ;;; The alignment restrictions for this SC. TNs will only be
99 ;;; allocated at offsets that are an even multiple of this number.
100 ;;; This defaults to 1.
102 ;;; :LOCATIONS (Location*)
103 ;;; If the SB is :FINITE, then this is a list of the offsets within
104 ;;; the SB that are in this SC.
106 ;;; :RESERVE-LOCATIONS (Location*)
107 ;;; A subset of the Locations that the register allocator should try to
108 ;;; reserve for operand loading (instead of to hold variable values.)
110 ;;; :SAVE-P {T | NIL}
111 ;;; If T, then values stored in this SC must be saved in one of the
112 ;;; non-save-p :ALTERNATE-SCs across calls.
114 ;;; :ALTERNATE-SCS (SC*)
115 ;;; Indicates other SCs that can be used to hold values from this SC across
116 ;;; calls or when storage in this SC is exhausted. The SCs should be
117 ;;; specified in order of decreasing \"goodness\". There must be at least
118 ;;; one SC in an unbounded SB, unless this SC is only used for restricted or
121 ;;; :CONSTANT-SCS (SC*)
122 ;;; A list of the names of all the constant SCs that can be loaded into this
123 ;;; SC by a move function.
124 (defmacro define-storage-class (name number sb-name &key (element-size '1)
125 (alignment '1) locations reserve-locations
126 save-p alternate-scs constant-scs)
127 (declare (type symbol name))
128 (declare (type sc-number number))
129 (declare (type symbol sb-name))
130 (declare (type list locations reserve-locations alternate-scs constant-scs))
131 (declare (type boolean save-p))
132 (unless (= (logcount alignment) 1)
133 (error "alignment not a power of two: ~W" alignment))
135 (let ((sb (meta-sb-or-lose sb-name)))
136 (if (eq (sb-kind sb) :finite)
137 (let ((size (sb-size sb))
138 (element-size (eval element-size)))
139 (declare (type unsigned-byte element-size))
140 (dolist (el locations)
141 (declare (type unsigned-byte el))
142 (unless (<= 1 (+ el element-size) size)
143 (error "SC element ~W out of bounds for ~S" el sb))))
145 (error ":LOCATIONS is meaningless in a ~S SB." (sb-kind sb))))
147 (unless (subsetp reserve-locations locations)
148 (error "RESERVE-LOCATIONS not a subset of LOCATIONS."))
150 (when (and (or alternate-scs constant-scs)
151 (eq (sb-kind sb) :non-packed))
153 "It's meaningless to specify alternate or constant SCs in a ~S SB."
157 (if (or (eq sb-name 'non-descriptor-stack)
158 (find 'non-descriptor-stack
159 (mapcar #'meta-sc-or-lose alternate-scs)
161 (sb-name (sc-sb x)))))
164 (eval-when (:compile-toplevel :load-toplevel :execute)
165 (let ((res (make-sc :name ',name :number ',number
166 :sb (meta-sb-or-lose ',sb-name)
167 :element-size ,element-size
168 :alignment ,alignment
169 :locations ',locations
170 :reserve-locations ',reserve-locations
172 :number-stack-p ,nstack-p
173 :alternate-scs (mapcar #'meta-sc-or-lose
175 :constant-scs (mapcar #'meta-sc-or-lose
177 (setf (gethash ',name *backend-meta-sc-names*) res)
178 (setf (svref *backend-meta-sc-numbers* ',number) res)
179 (setf (svref (sc-load-costs res) ',number) 0)))
181 (let ((old (svref *backend-sc-numbers* ',number)))
182 (when (and old (not (eq (sc-name old) ',name)))
183 (warn "redefining SC number ~W from ~S to ~S" ',number
184 (sc-name old) ',name)))
186 (setf (svref *backend-sc-numbers* ',number)
187 (meta-sc-or-lose ',name))
188 (setf (gethash ',name *backend-sc-names*)
189 (meta-sc-or-lose ',name))
190 (setf (sc-sb (sc-or-lose ',name)) (sb-or-lose ',sb-name))
193 ;;;; move/coerce definition
195 ;;; Given a list of pairs of lists of SCs (as given to DEFINE-MOVE-VOP,
196 ;;; etc.), bind TO-SC and FROM-SC to all the combinations.
197 (defmacro do-sc-pairs ((from-sc-var to-sc-var scs) &body body)
198 `(do ((froms ,scs (cddr froms))
199 (tos (cdr ,scs) (cddr tos)))
201 (dolist (from (car froms))
202 (let ((,from-sc-var (meta-sc-or-lose from)))
203 (dolist (to (car tos))
204 (let ((,to-sc-var (meta-sc-or-lose to)))
207 ;;; Define the function NAME and note it as the function used for
208 ;;; moving operands from the From-SCs to the To-SCs. Cost is the cost
209 ;;; of this move operation. The function is called with three
210 ;;; arguments: the VOP (for context), and the source and destination
211 ;;; TNs. An ASSEMBLE form is wrapped around the body. All uses of
212 ;;; DEFINE-MOVE-FUN should be compiled before any uses of
214 (defmacro define-move-fun ((name cost) lambda-list scs &body body)
215 (declare (type index cost))
216 (when (or (oddp (length scs)) (null scs))
217 (error "malformed SCs spec: ~S" scs))
219 (eval-when (:compile-toplevel :load-toplevel :execute)
220 (do-sc-pairs (from-sc to-sc ',scs)
221 (unless (eq from-sc to-sc)
222 (let ((num (sc-number from-sc)))
223 (setf (svref (sc-move-funs to-sc) num) ',name)
224 (setf (svref (sc-load-costs to-sc) num) ',cost)))))
226 (defun ,name ,lambda-list
227 (sb!assem:assemble (*code-segment* ,(first lambda-list))
230 (eval-when (:compile-toplevel :load-toplevel :execute)
231 (defparameter *sc-vop-slots*
232 '((:move . sc-move-vops)
233 (:move-arg . sc-move-arg-vops))))
235 ;;; Make NAME be the VOP used to move values in the specified FROM-SCs
236 ;;; to the representation of the TO-SCs of each SC pair in SCS.
238 ;;; If KIND is :MOVE-ARG, then the VOP takes an extra argument,
239 ;;; which is the frame pointer of the frame to move into.
241 ;;; We record the VOP and costs for all SCs that we can move between
242 ;;; (including implicit loading).
243 (defmacro define-move-vop (name kind &rest scs)
244 (when (or (oddp (length scs)) (null scs))
245 (error "malformed SCs spec: ~S" scs))
246 (let ((accessor (or (cdr (assoc kind *sc-vop-slots*))
247 (error "unknown kind ~S" kind))))
249 ,@(when (eq kind :move)
250 `((eval-when (:compile-toplevel :load-toplevel :execute)
251 (do-sc-pairs (from-sc to-sc ',scs)
252 (compute-move-costs from-sc to-sc
254 (vop-parse-or-lose name)))))))
256 (let ((vop (template-or-lose ',name)))
257 (do-sc-pairs (from-sc to-sc ',scs)
258 (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc)))
259 (let ((vec (,accessor dest-sc)))
260 (let ((scn (sc-number from-sc)))
261 (setf (svref vec scn)
262 (adjoin-template vop (svref vec scn))))
263 (dolist (sc (append (sc-alternate-scs from-sc)
264 (sc-constant-scs from-sc)))
265 (let ((scn (sc-number sc)))
266 (setf (svref vec scn)
267 (adjoin-template vop (svref vec scn))))))))))))
269 ;;;; primitive type definition
271 (defun meta-primitive-type-or-lose (name)
273 (or (gethash name *backend-meta-primitive-type-names*)
274 (error "~S is not a defined primitive type." name))))
276 ;;; Define a primitive type NAME. Each SCS entry specifies a storage
277 ;;; class that values of this type may be allocated in. TYPE is the
278 ;;; type descriptor for the Lisp type that is equivalent to this type.
279 (defmacro !def-primitive-type (name scs &key (type name))
280 (declare (type symbol name) (type list scs))
281 (let ((scns (mapcar #'meta-sc-number-or-lose scs)))
283 (/show0 "doing !DEF-PRIMITIVE-TYPE, NAME=..")
284 (/primitive-print ,(symbol-name name))
285 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
286 (setf (gethash ',name *backend-meta-primitive-type-names*)
287 (make-primitive-type :name ',name
290 ,(once-only ((n-old `(gethash ',name *backend-primitive-type-names*)))
292 ;; If the PRIMITIVE-TYPE structure already exists, we
293 ;; destructively modify it so that existing references in
294 ;; templates won't be invalidated. FIXME: This should no
295 ;; longer be an issue in SBCL, since we don't try to do
296 ;; serious surgery on ourselves. Probably this should
297 ;; just become an assertion that N-OLD is NIL, so that we
298 ;; don't have to try to maintain the correctness of the
299 ;; never-ordinarily-used clause.
300 (/show0 "in !DEF-PRIMITIVE-TYPE, about to COND")
302 (/show0 "in ,N-OLD clause of COND")
303 (setf (primitive-type-scs ,n-old) ',scns)
304 (setf (primitive-type-specifier ,n-old) ',type))
306 (/show0 "in T clause of COND")
307 (setf (gethash ',name *backend-primitive-type-names*)
308 (make-primitive-type :name ',name
310 :specifier ',type))))
311 (/show0 "done with !DEF-PRIMITIVE-TYPE")
314 ;;; Define NAME to be an alias for RESULT in VOP operand type restrictions.
315 (defmacro !def-primitive-type-alias (name result)
316 ;; Just record the translation.
317 `(eval-when (:compile-toplevel :load-toplevel :execute)
318 (setf (gethash ',name *backend-primitive-type-aliases*) ',result)
321 (defparameter *primitive-type-slot-alist*
322 '((:check . primitive-type-check)))
324 ;;; Primitive-Type-VOP Vop (Kind*) Type*
326 ;;; Annotate all the specified primitive Types with the named VOP
327 ;;; under each of the specified kinds:
330 ;;; A one-argument one-result VOP that moves the argument to the
331 ;;; result, checking that the value is of this type in the process.
332 (defmacro primitive-type-vop (vop kinds &rest types)
333 (let ((n-vop (gensym))
335 `(let ((,n-vop (template-or-lose ',vop)))
338 `(let ((,n-type (primitive-type-or-lose ',type)))
341 (let ((slot (or (cdr (assoc kind
342 *primitive-type-slot-alist*))
343 (error "unknown kind: ~S" kind))))
344 `(setf (,slot ,n-type) ,n-vop)))
349 ;;; Return true if SC is either one of PTYPE's SC's, or one of those
350 ;;; SC's alternate or constant SCs.
351 (defun meta-sc-allowed-by-primitive-type (sc ptype)
352 (declare (type sc sc) (type primitive-type ptype))
353 (let ((scn (sc-number sc)))
354 (dolist (allowed (primitive-type-scs ptype) nil)
355 (when (eql allowed scn)
357 (let ((allowed-sc (svref *backend-meta-sc-numbers* allowed)))
358 (when (or (member sc (sc-alternate-scs allowed-sc))
359 (member sc (sc-constant-scs allowed-sc)))
362 ;;;; VOP definition structures
364 ;;;; DEFINE-VOP uses some fairly complex data structures at
365 ;;;; meta-compile time, both to hold the results of parsing the
366 ;;;; elaborate syntax and to retain the information so that it can be
367 ;;;; inherited by other VOPs.
369 ;;; A VOP-PARSE object holds everything we need to know about a VOP at
370 ;;; meta-compile time.
371 (def!struct (vop-parse
372 (:make-load-form-fun just-dump-it-normally)
373 #-sb-xc-host (:pure t))
374 ;; the name of this VOP
375 (name nil :type symbol)
376 ;; If true, then the name of the VOP we inherit from.
377 (inherits nil :type (or symbol null))
378 ;; lists of OPERAND-PARSE structures describing the arguments,
379 ;; results and temporaries of the VOP
380 (args nil :type list)
381 (results nil :type list)
382 (temps nil :type list)
383 ;; OPERAND-PARSE structures containing information about more args
384 ;; and results. If null, then there there are no more operands of
386 (more-args nil :type (or operand-parse null))
387 (more-results nil :type (or operand-parse null))
388 ;; a list of all the above together
389 (operands nil :type list)
390 ;; names of variables that should be declared IGNORE
391 (ignores () :type list)
392 ;; true if this is a :CONDITIONAL VOP. T if a branchful VOP,
393 ;; a list of condition descriptor otherwise. See $ARCH/pred.lisp
394 ;; for more information.
396 ;; argument and result primitive types. These are pulled out of the
397 ;; operands, since we often want to change them without respecifying
399 (arg-types :unspecified :type (or (member :unspecified) list))
400 (result-types :unspecified :type (or (member :unspecified) list))
401 ;; the guard expression specified, or NIL if none
403 ;; the cost of and body code for the generator
404 (cost 0 :type unsigned-byte)
405 (body :unspecified :type (or (member :unspecified) list))
406 ;; info for VOP variants. The list of forms to be evaluated to get
407 ;; the variant args for this VOP, and the list of variables to be
408 ;; bound to the variant args.
409 (variant () :type list)
410 (variant-vars () :type list)
411 ;; variables bound to the VOP and Vop-Node when in the generator body
412 (vop-var '.vop. :type symbol)
413 (node-var nil :type (or symbol null))
414 ;; a list of the names of the codegen-info arguments to this VOP
415 (info-args () :type list)
416 ;; an efficiency note associated with this VOP
417 (note nil :type (or string null))
418 ;; a list of the names of the Effects and Affected attributes for
420 (effects '(any) :type list)
421 (affected '(any) :type list)
422 ;; a list of the names of functions this VOP is a translation of and
423 ;; the policy that allows this translation to be done. :FAST is a
424 ;; safe default, since it isn't a safe policy.
425 (translate () :type list)
426 (ltn-policy :fast :type ltn-policy)
427 ;; stuff used by life analysis
428 (save-p nil :type (member t nil :compute-only :force-to-stack))
429 ;; info about how to emit MOVE-ARG VOPs for the &MORE operand in
431 (move-args nil :type (member nil :local-call :full-call :known-return)))
432 (defprinter (vop-parse)
434 (inherits :test inherits)
438 (more-args :test more-args)
439 (more-results :test more-results)
440 (conditional-p :test conditional-p)
446 (variant :test variant)
447 (variant-vars :test variant-vars)
448 (info-args :test info-args)
454 (save-p :test save-p)
455 (move-args :test move-args))
457 ;;; An OPERAND-PARSE object contains stuff we need to know about an
458 ;;; operand or temporary at meta-compile time. Besides the obvious
459 ;;; stuff, we also store the names of per-operand temporaries here.
460 (def!struct (operand-parse
461 (:make-load-form-fun just-dump-it-normally)
462 #-sb-xc-host (:pure t))
463 ;; name of the operand (which we bind to the TN)
464 (name nil :type symbol)
465 ;; the way this operand is used:
467 :type (member :argument :result :temporary
468 :more-argument :more-result))
469 ;; If true, the name of an operand that this operand is targeted to.
470 ;; This is only meaningful in :ARGUMENT and :TEMPORARY operands.
471 (target nil :type (or symbol null))
472 ;; TEMP is a temporary that holds the TN-REF for this operand.
473 (temp (make-operand-parse-temp) :type symbol)
474 ;; the time that this operand is first live and the time at which it
475 ;; becomes dead again. These are TIME-SPECs, as returned by
479 ;; a list of the names of the SCs that this operand is allowed into.
480 ;; If false, there is no restriction.
482 ;; Variable that is bound to the load TN allocated for this operand, or to
483 ;; NIL if no load-TN was allocated.
484 (load-tn (make-operand-parse-load-tn) :type symbol)
485 ;; an expression that tests whether to do automatic operand loading
487 ;; In a wired or restricted temporary this is the SC the TN is to be
488 ;; packed in. Null otherwise.
489 (sc nil :type (or symbol null))
490 ;; If non-null, we are a temp wired to this offset in SC.
491 (offset nil :type (or unsigned-byte null)))
492 (defprinter (operand-parse)
495 (target :test target)
501 (offset :test offset))
503 ;;;; miscellaneous utilities
505 ;;; Find the operand or temporary with the specifed Name in the VOP
506 ;;; Parse. If there is no such operand, signal an error. Also error if
507 ;;; the operand kind isn't one of the specified Kinds. If Error-P is
508 ;;; NIL, just return NIL if there is no such operand.
509 (defun find-operand (name parse &optional
510 (kinds '(:argument :result :temporary))
512 (declare (symbol name) (type vop-parse parse) (list kinds))
513 (let ((found (find name (vop-parse-operands parse)
514 :key #'operand-parse-name)))
516 (unless (member (operand-parse-kind found) kinds)
517 (error "Operand ~S isn't one of these kinds: ~S." name kinds))
519 (error "~S is not an operand to ~S." name (vop-parse-name parse))))
522 ;;; Get the VOP-PARSE structure for NAME or die trying. For all
523 ;;; meta-compile time uses, the VOP-PARSE should be used instead of
525 (defun vop-parse-or-lose (name)
527 (or (gethash name *backend-parsed-vops*)
528 (error "~S is not the name of a defined VOP." name))))
530 ;;; Return a list of LET-forms to parse a TN-REF list into the temps
531 ;;; specified by the operand-parse structures. MORE-OPERAND is the
532 ;;; OPERAND-PARSE describing any more operand, or NIL if none. REFS is
533 ;;; an expression that evaluates into the first TN-REF.
534 (defun access-operands (operands more-operand refs)
535 (declare (list operands))
538 (dolist (op operands)
539 (let ((n-ref (operand-parse-temp op)))
540 (res `(,n-ref ,prev))
541 (setq prev `(tn-ref-across ,n-ref))))
544 (res `(,(operand-parse-name more-operand) ,prev))))
547 ;;; This is used with ACCESS-OPERANDS to prevent warnings for TN-REF
548 ;;; temps not used by some particular function. It returns the name of
549 ;;; the last operand, or NIL if OPERANDS is NIL.
550 (defun ignore-unreferenced-temps (operands)
552 (operand-parse-temp (car (last operands)))))
554 ;;; Grab an arg out of a VOP spec, checking the type and syntax and stuff.
555 (defun vop-spec-arg (spec type &optional (n 1) (last t))
556 (let ((len (length spec)))
558 (error "~:R argument missing: ~S" n spec))
559 (when (and last (> len (1+ n)))
560 (error "extra junk at end of ~S" spec))
561 (let ((thing (elt spec n)))
562 (unless (typep thing type)
563 (error "~:R argument is not a ~S: ~S" n type spec))
568 ;;; Return a time spec describing a time during the evaluation of a
569 ;;; VOP, used to delimit operand and temporary lifetimes. The
570 ;;; representation is a cons whose CAR is the number of the evaluation
571 ;;; phase and the CDR is the sub-phase. The sub-phase is 0 in the
572 ;;; :LOAD and :SAVE phases.
573 (defun parse-time-spec (spec)
574 (let ((dspec (if (atom spec) (list spec 0) spec)))
575 (unless (and (= (length dspec) 2)
576 (typep (second dspec) 'unsigned-byte))
577 (error "malformed time specifier: ~S" spec))
579 (cons (case (first dspec)
586 (error "unknown phase in time specifier: ~S" spec)))
589 ;;; Return true if the time spec X is the same or later time than Y.
590 (defun time-spec-order (x y)
591 (or (> (car x) (car y))
592 (and (= (car x) (car y))
593 (>= (cdr x) (cdr y)))))
595 ;;;; generation of emit functions
597 (defun compute-temporaries-description (parse)
598 (let ((temps (vop-parse-temps parse))
599 (element-type '(unsigned-byte 16)))
601 (let ((results (make-specializable-array
603 :element-type element-type))
606 (declare (type operand-parse temp))
607 (let ((sc (operand-parse-sc temp))
608 (offset (operand-parse-offset temp)))
610 (setf (aref results index)
612 (+ (ash offset (1+ sc-bits))
613 (ash (meta-sc-number-or-lose sc) 1)
615 (ash (meta-sc-number-or-lose sc) 1))))
617 ;; KLUDGE: As in the other COERCEs wrapped around with
618 ;; MAKE-SPECIALIZABLE-ARRAY results in COMPUTE-REF-ORDERING,
619 ;; this coercion could be removed by a sufficiently smart
620 ;; compiler, but I dunno whether Python is that smart. It
621 ;; would be good to check this and help it if it's not smart
622 ;; enough to remove it for itself. However, it's probably not
623 ;; urgent, since the overhead of an extra no-op conversion is
624 ;; unlikely to be large compared to consing and corresponding
625 ;; GC. -- WHN ca. 19990701
626 `(coerce ,results '(specializable-vector ,element-type))))))
628 (defun compute-ref-ordering (parse)
629 (let* ((num-args (+ (length (vop-parse-args parse))
630 (if (vop-parse-more-args parse) 1 0)))
631 (num-results (+ (length (vop-parse-results parse))
632 (if (vop-parse-more-results parse) 1 0)))
634 (collect ((refs) (targets))
635 (dolist (op (vop-parse-operands parse))
636 (when (operand-parse-target op)
637 (unless (member (operand-parse-kind op) '(:argument :temporary))
638 (error "cannot target a ~S operand: ~S" (operand-parse-kind op)
639 (operand-parse-name op)))
640 (let ((target (find-operand (operand-parse-target op) parse
641 '(:temporary :result))))
642 ;; KLUDGE: These formulas must be consistent with those in
643 ;; %EMIT-GENERIC-VOP, and this is currently maintained by
644 ;; hand. -- WHN 2002-01-30, paraphrasing APD
645 (targets (+ (* index max-vop-tn-refs)
646 (ecase (operand-parse-kind target)
648 (+ (position-or-lose target
649 (vop-parse-results parse))
652 (+ (* (position-or-lose target
653 (vop-parse-temps parse))
658 (let ((born (operand-parse-born op))
659 (dies (operand-parse-dies op)))
660 (ecase (operand-parse-kind op)
662 (refs (cons (cons dies nil) index)))
664 (refs (cons (cons dies nil) index)))
666 (refs (cons (cons born t) index)))
668 (refs (cons (cons born t) index)))
670 (refs (cons (cons dies nil) index))
672 (refs (cons (cons born t) index))))
674 (let* ((sorted (sort (refs)
676 (let ((x-time (car x))
678 (if (time-spec-order x-time y-time)
679 (if (time-spec-order y-time x-time)
680 (and (not (cdr x)) (cdr y))
684 ;; :REF-ORDERING element type
686 ;; KLUDGE: was (MOD #.MAX-VOP-TN-REFS), which is still right
687 (oe-type '(unsigned-byte 8))
688 ;; :TARGETS element-type
690 ;; KLUDGE: was (MOD #.(* MAX-VOP-TN-REFS 2)), which does
691 ;; not correspond to the definition in
692 ;; src/compiler/vop.lisp.
693 (te-type '(unsigned-byte 16))
694 (ordering (make-specializable-array
696 :element-type oe-type)))
699 (setf (aref ordering index) (cdr ref))
701 `(:num-args ,num-args
702 :num-results ,num-results
703 ;; KLUDGE: The (COERCE .. (SPECIALIZABLE-VECTOR ..)) wrapper
704 ;; here around the result returned by
705 ;; MAKE-SPECIALIZABLE-ARRAY above was of course added to
706 ;; help with cross-compilation. "A sufficiently smart
707 ;; compiler" should be able to optimize all this away in the
708 ;; final target Lisp, leaving a single MAKE-ARRAY with no
709 ;; subsequent coercion. However, I don't know whether Python
710 ;; is that smart. (Can it figure out the return type of
711 ;; MAKE-ARRAY? Does it know that COERCE can be optimized
712 ;; away if the input type is known to be the same as the
713 ;; COERCEd-to type?) At some point it would be good to test
714 ;; to see whether this construct is in fact causing run-time
715 ;; overhead, and fix it if so. (Some declarations of the
716 ;; types returned by MAKE-ARRAY might be enough to fix it.)
717 ;; However, it's probably not urgent to fix this, since it's
718 ;; hard to imagine that any overhead caused by calling
719 ;; COERCE and letting it decide to bail out could be large
720 ;; compared to the cost of consing and GCing the vectors in
721 ;; the first place. -- WHN ca. 19990701
722 :ref-ordering (coerce ',ordering
723 '(specializable-vector ,oe-type))
725 `(:targets (coerce ',(targets)
726 '(specializable-vector ,te-type)))))))))
728 (defun make-emit-function-and-friends (parse)
729 `(:emit-function #'emit-generic-vop
730 :temps ,(compute-temporaries-description parse)
731 ,@(compute-ref-ordering parse)))
733 ;;;; generator functions
735 ;;; Return an alist that translates from lists of SCs we can load OP
736 ;;; from to the move function used for loading those SCs. We quietly
737 ;;; ignore restrictions to :non-packed (constant) and :unbounded SCs,
738 ;;; since we don't load into those SCs.
739 (defun find-move-funs (op load-p)
741 (dolist (sc-name (operand-parse-scs op))
742 (let* ((sc (meta-sc-or-lose sc-name))
744 (load-scs (append (when load-p
745 (sc-constant-scs sc))
746 (sc-alternate-scs sc))))
749 (dolist (alt load-scs)
750 (unless (member (sc-name alt) (operand-parse-scs op) :test #'eq)
751 (let* ((altn (sc-number alt))
753 (svref (sc-move-funs sc) altn)
754 (svref (sc-move-funs alt) scn)))
755 (found (or (assoc alt (funs) :test #'member)
756 (rassoc name (funs)))))
758 (error "no move function defined to ~:[save~;load~] SC ~S ~
759 ~:[to~;from~] from SC ~S"
760 load-p sc-name load-p (sc-name alt)))
763 (unless (eq (cdr found) name)
764 (error "can't tell whether to ~:[save~;load~]~@
765 with ~S or ~S when operand is in SC ~S"
766 load-p name (cdr found) (sc-name alt)))
767 (pushnew alt (car found)))
769 (funs (cons (list alt) name))))))))
770 ((member (sb-kind (sc-sb sc)) '(:non-packed :unbounded)))
772 (error "SC ~S has no alternate~:[~; or constant~] SCs, yet it is~@
773 mentioned in the restriction for operand ~S"
774 sc-name load-p (operand-parse-name op))))))
777 ;;; Return a form to load/save the specified operand when it has a
778 ;;; load TN. For any given SC that we can load from, there must be a
779 ;;; unique load function. If all SCs we can load from have the same
780 ;;; move function, then we just call that when there is a load TN. If
781 ;;; there are multiple possible move functions, then we dispatch off
782 ;;; of the operand TN's type to see which move function to use.
783 (defun call-move-fun (parse op load-p)
784 (let ((funs (find-move-funs op load-p))
785 (load-tn (operand-parse-load-tn op)))
787 (let* ((tn `(tn-ref-tn ,(operand-parse-temp op)))
788 (n-vop (or (vop-parse-vop-var parse)
789 (setf (vop-parse-vop-var parse) '.vop.)))
790 (form (if (rest funs)
792 ,@(mapcar (lambda (x)
793 `(,(mapcar #'sc-name (car x))
795 `(,(cdr x) ,n-vop ,tn
797 `(,(cdr x) ,n-vop ,load-tn
801 `(,(cdr (first funs)) ,n-vop ,tn ,load-tn)
802 `(,(cdr (first funs)) ,n-vop ,load-tn ,tn)))))
803 (if (eq (operand-parse-load op) t)
804 `(when ,load-tn ,form)
805 `(when (eq ,load-tn ,(operand-parse-name op))
808 (error "load TN allocated, but no move function?~@
809 VM definition is inconsistent, recompile and try again.")))))
811 ;;; Return the TN that we should bind to the operand's var in the
812 ;;; generator body. In general, this involves evaluating the :LOAD-IF
814 (defun decide-to-load (parse op)
815 (let ((load (operand-parse-load op))
816 (load-tn (operand-parse-load-tn op))
817 (temp (operand-parse-temp op)))
819 `(or ,load-tn (tn-ref-tn ,temp))
822 (dolist (x (vop-parse-operands parse))
823 (when (member (operand-parse-kind x) '(:argument :result))
824 (let ((name (operand-parse-name x)))
825 (binds `(,name (tn-ref-tn ,(operand-parse-temp x))))
829 (declare (ignorable ,@(ignores)))
832 (tn-ref-tn ,temp))))))
834 ;;; Make a lambda that parses the VOP TN-REFS, does automatic operand
835 ;;; loading, and runs the appropriate code generator.
836 (defun make-generator-function (parse)
837 (declare (type vop-parse parse))
838 (let ((n-vop (vop-parse-vop-var parse))
839 (operands (vop-parse-operands parse))
840 (n-info (gensym)) (n-variant (gensym)))
844 (dolist (op operands)
845 (ecase (operand-parse-kind op)
847 (let ((temp (operand-parse-temp op))
848 (name (operand-parse-name op)))
849 (cond ((and (operand-parse-load op) (operand-parse-scs op))
850 (binds `(,(operand-parse-load-tn op)
851 (tn-ref-load-tn ,temp)))
852 (binds `(,name ,(decide-to-load parse op)))
853 (if (eq (operand-parse-kind op) :argument)
854 (loads (call-move-fun parse op t))
855 (saves (call-move-fun parse op nil))))
857 (binds `(,name (tn-ref-tn ,temp)))))))
859 (binds `(,(operand-parse-name op)
860 (tn-ref-tn ,(operand-parse-temp op)))))
861 ((:more-argument :more-result))))
864 (let* (,@(access-operands (vop-parse-args parse)
865 (vop-parse-more-args parse)
867 ,@(access-operands (vop-parse-results parse)
868 (vop-parse-more-results parse)
869 `(vop-results ,n-vop))
870 ,@(access-operands (vop-parse-temps parse) nil
872 ,@(when (vop-parse-info-args parse)
873 `((,n-info (vop-codegen-info ,n-vop))
874 ,@(mapcar (lambda (x) `(,x (pop ,n-info)))
875 (vop-parse-info-args parse))))
876 ,@(when (vop-parse-variant-vars parse)
877 `((,n-variant (vop-info-variant (vop-info ,n-vop)))
878 ,@(mapcar (lambda (x) `(,x (pop ,n-variant)))
879 (vop-parse-variant-vars parse))))
880 ,@(when (vop-parse-node-var parse)
881 `((,(vop-parse-node-var parse) (vop-node ,n-vop))))
883 (declare (ignore ,@(vop-parse-ignores parse)))
885 (sb!assem:assemble (*code-segment* ,n-vop)
886 ,@(vop-parse-body parse))
889 (defvar *parse-vop-operand-count*)
890 (defun make-operand-parse-temp ()
891 (without-package-locks
892 (intern (format nil "OPERAND-PARSE-TEMP-~D" *parse-vop-operand-count*)
893 (symbol-package '*parse-vop-operand-count*))))
894 (defun make-operand-parse-load-tn ()
895 (without-package-locks
896 (intern (format nil "OPERAND-PARSE-LOAD-TN-~D" *parse-vop-operand-count*)
897 (symbol-package '*parse-vop-operand-count*))))
899 ;;; Given a list of operand specifications as given to DEFINE-VOP,
900 ;;; return a list of OPERAND-PARSE structures describing the fixed
901 ;;; operands, and a single OPERAND-PARSE describing any more operand.
902 ;;; If we are inheriting a VOP, we default attributes to the inherited
903 ;;; operand of the same name.
904 (defun !parse-vop-operands (parse specs kind)
905 (declare (list specs)
906 (type (member :argument :result) kind))
909 (collect ((operands))
911 (unless (and (consp spec) (symbolp (first spec)) (oddp (length spec)))
912 (error "malformed operand specifier: ~S" spec))
914 (error "The MORE operand isn't the last operand: ~S" specs))
915 (incf *parse-vop-operand-count*)
916 (let* ((name (first spec))
917 (old (if (vop-parse-inherits parse)
920 (vop-parse-inherits parse))
928 :target (operand-parse-target old)
929 :born (operand-parse-born old)
930 :dies (operand-parse-dies old)
931 :scs (operand-parse-scs old)
932 :load-tn (operand-parse-load-tn old)
933 :load (operand-parse-load old))
939 :born (parse-time-spec :load)
940 :dies (parse-time-spec `(:argument ,(incf num)))))
945 :born (parse-time-spec `(:result ,(incf num)))
946 :dies (parse-time-spec :save)))))))
947 (do ((key (rest spec) (cddr key)))
949 (let ((value (second key)))
952 (aver (typep value 'list))
953 (setf (operand-parse-scs res) (remove-duplicates value)))
955 (aver (typep value 'symbol))
956 (setf (operand-parse-load-tn res) value))
958 (setf (operand-parse-load res) value))
960 (aver (typep value 'boolean))
961 (setf (operand-parse-kind res)
962 (if (eq kind :argument) :more-argument :more-result))
963 (setf (operand-parse-load res) nil)
966 (aver (typep value 'symbol))
967 (setf (operand-parse-target res) value))
969 (unless (eq kind :result)
970 (error "can only specify :FROM in a result: ~S" spec))
971 (setf (operand-parse-born res) (parse-time-spec value)))
973 (unless (eq kind :argument)
974 (error "can only specify :TO in an argument: ~S" spec))
975 (setf (operand-parse-dies res) (parse-time-spec value)))
977 (error "unknown keyword in operand specifier: ~S" spec)))))
981 ((operand-parse-target more)
982 (error "cannot specify :TARGET in a :MORE operand"))
983 ((operand-parse-load more)
984 (error "cannot specify :LOAD-IF in a :MORE operand")))))
985 (values (the list (operands)) more))))
987 ;;; Parse a temporary specification, putting the OPERAND-PARSE
988 ;;; structures in the PARSE structure.
989 (defun parse-temporary (spec parse)
991 (type vop-parse parse))
992 (let ((len (length spec)))
994 (error "malformed temporary spec: ~S" spec))
995 (unless (listp (second spec))
996 (error "malformed options list: ~S" (second spec)))
997 (unless (evenp (length (second spec)))
998 (error "odd number of arguments in keyword options: ~S" spec))
999 (unless (consp (cddr spec))
1000 (warn "temporary spec allocates no temps:~% ~S" spec))
1001 (dolist (name (cddr spec))
1002 (unless (symbolp name)
1003 (error "bad temporary name: ~S" name))
1004 (incf *parse-vop-operand-count*)
1005 (let ((res (make-operand-parse :name name
1007 :born (parse-time-spec :load)
1008 :dies (parse-time-spec :save))))
1009 (do ((opt (second spec) (cddr opt)))
1013 (setf (operand-parse-target res)
1014 (vop-spec-arg opt 'symbol 1 nil)))
1016 (setf (operand-parse-sc res)
1017 (vop-spec-arg opt 'symbol 1 nil)))
1019 (let ((offset (eval (second opt))))
1020 (aver (typep offset 'unsigned-byte))
1021 (setf (operand-parse-offset res) offset)))
1023 (setf (operand-parse-born res) (parse-time-spec (second opt))))
1025 (setf (operand-parse-dies res) (parse-time-spec (second opt))))
1026 ;; backward compatibility...
1028 (let ((scs (vop-spec-arg opt 'list 1 nil)))
1029 (unless (= (length scs) 1)
1030 (error "must specify exactly one SC for a temporary"))
1031 (setf (operand-parse-sc res) (first scs))))
1034 (error "unknown temporary option: ~S" opt))))
1036 (unless (and (time-spec-order (operand-parse-dies res)
1037 (operand-parse-born res))
1038 (not (time-spec-order (operand-parse-born res)
1039 (operand-parse-dies res))))
1040 (error "Temporary lifetime doesn't begin before it ends: ~S" spec))
1042 (unless (operand-parse-sc res)
1043 (error "must specify :SC for all temporaries: ~S" spec))
1045 (setf (vop-parse-temps parse)
1047 (remove name (vop-parse-temps parse)
1048 :key #'operand-parse-name))))))
1051 (defun compute-parse-vop-operand-count (parse)
1052 (declare (type vop-parse parse))
1053 (labels ((compute-count-aux (parse)
1054 (declare (type vop-parse parse))
1055 (if (null (vop-parse-inherits parse))
1056 (length (vop-parse-operands parse))
1057 (+ (length (vop-parse-operands parse))
1059 (vop-parse-or-lose (vop-parse-inherits parse)))))))
1060 (if (null (vop-parse-inherits parse))
1062 (compute-count-aux (vop-parse-or-lose (vop-parse-inherits parse))))))
1064 ;;; the top level parse function: clobber PARSE to represent the
1065 ;;; specified options.
1066 (defun parse-define-vop (parse specs)
1067 (declare (type vop-parse parse) (list specs))
1068 (let ((*parse-vop-operand-count* (compute-parse-vop-operand-count parse)))
1069 (dolist (spec specs)
1070 (unless (consp spec)
1071 (error "malformed option specification: ~S" spec))
1074 (multiple-value-bind (fixed more)
1075 (!parse-vop-operands parse (rest spec) :argument)
1076 (setf (vop-parse-args parse) fixed)
1077 (setf (vop-parse-more-args parse) more)))
1079 (multiple-value-bind (fixed more)
1080 (!parse-vop-operands parse (rest spec) :result)
1081 (setf (vop-parse-results parse) fixed)
1082 (setf (vop-parse-more-results parse) more))
1083 (setf (vop-parse-conditional-p parse) nil))
1085 (setf (vop-parse-result-types parse) ())
1086 (setf (vop-parse-results parse) ())
1087 (setf (vop-parse-more-results parse) nil)
1088 (setf (vop-parse-conditional-p parse) (or (rest spec) t)))
1090 (parse-temporary spec parse))
1092 (setf (vop-parse-cost parse)
1093 (vop-spec-arg spec 'unsigned-byte 1 nil))
1094 (setf (vop-parse-body parse) (cddr spec)))
1096 (setf (vop-parse-effects parse) (rest spec)))
1098 (setf (vop-parse-affected parse) (rest spec)))
1100 (setf (vop-parse-info-args parse) (rest spec)))
1102 (setf (vop-parse-ignores parse) (rest spec)))
1104 (setf (vop-parse-variant parse) (rest spec)))
1106 (let ((vars (rest spec)))
1107 (setf (vop-parse-variant-vars parse) vars)
1108 (setf (vop-parse-variant parse)
1109 (make-list (length vars) :initial-element nil))))
1111 (setf (vop-parse-cost parse) (vop-spec-arg spec 'unsigned-byte)))
1113 (setf (vop-parse-vop-var parse) (vop-spec-arg spec 'symbol)))
1115 (setf (vop-parse-move-args parse)
1116 (vop-spec-arg spec '(member nil :local-call :full-call
1119 (setf (vop-parse-node-var parse) (vop-spec-arg spec 'symbol)))
1121 (setf (vop-parse-note parse) (vop-spec-arg spec '(or string null))))
1123 (setf (vop-parse-arg-types parse)
1124 (!parse-vop-operand-types (rest spec) t)))
1126 (setf (vop-parse-result-types parse)
1127 (!parse-vop-operand-types (rest spec) nil)))
1129 (setf (vop-parse-translate parse) (rest spec)))
1131 (setf (vop-parse-guard parse) (vop-spec-arg spec t)))
1132 ;; FIXME: :LTN-POLICY would be a better name for this. It
1133 ;; would probably be good to leave it unchanged for a while,
1134 ;; though, at least until the first port to some other
1135 ;; architecture, since the renaming would be a change to the
1136 ;; interface between
1138 (setf (vop-parse-ltn-policy parse)
1139 (vop-spec-arg spec 'ltn-policy)))
1141 (setf (vop-parse-save-p parse)
1143 '(member t nil :compute-only :force-to-stack))))
1145 (error "unknown option specifier: ~S" (first spec)))))
1148 ;;;; making costs and restrictions
1150 ;;; Given an operand, returns two values:
1151 ;;; 1. A SC-vector of the cost for the operand being in that SC,
1152 ;;; including both the costs for move functions and coercion VOPs.
1153 ;;; 2. A SC-vector holding the SC that we load into, for any SC
1154 ;;; that we can directly load from.
1156 ;;; In both vectors, unused entries are NIL. LOAD-P specifies the
1157 ;;; direction: if true, we are loading, if false we are saving.
1158 (defun compute-loading-costs (op load-p)
1159 (declare (type operand-parse op))
1160 (let ((scs (operand-parse-scs op))
1161 (costs (make-array sc-number-limit :initial-element nil))
1162 (load-scs (make-array sc-number-limit :initial-element nil)))
1163 (dolist (sc-name scs)
1164 (let* ((load-sc (meta-sc-or-lose sc-name))
1165 (load-scn (sc-number load-sc)))
1166 (setf (svref costs load-scn) 0)
1167 (setf (svref load-scs load-scn) t)
1168 (dolist (op-sc (append (when load-p
1169 (sc-constant-scs load-sc))
1170 (sc-alternate-scs load-sc)))
1171 (let* ((op-scn (sc-number op-sc))
1173 (aref (sc-load-costs load-sc) op-scn)
1174 (aref (sc-load-costs op-sc) load-scn))))
1176 (error "no move function defined to move ~:[from~;to~] SC ~
1177 ~S~%~:[to~;from~] alternate or constant SC ~S"
1178 load-p sc-name load-p (sc-name op-sc)))
1180 (let ((op-cost (svref costs op-scn)))
1181 (when (or (not op-cost) (< load op-cost))
1182 (setf (svref costs op-scn) load)))
1184 (let ((op-load (svref load-scs op-scn)))
1185 (unless (eq op-load t)
1186 (pushnew load-scn (svref load-scs op-scn))))))
1188 (dotimes (i sc-number-limit)
1189 (unless (svref costs i)
1190 (let ((op-sc (svref *backend-meta-sc-numbers* i)))
1192 (let ((cost (if load-p
1193 (svref (sc-move-costs load-sc) i)
1194 (svref (sc-move-costs op-sc) load-scn))))
1196 (setf (svref costs i) cost)))))))))
1198 (values costs load-scs)))
1200 (defparameter *no-costs*
1201 (make-array sc-number-limit :initial-element 0))
1203 (defparameter *no-loads*
1204 (make-array sc-number-limit :initial-element t))
1206 ;;; Pick off the case of operands with no restrictions.
1207 (defun compute-loading-costs-if-any (op load-p)
1208 (declare (type operand-parse op))
1209 (if (operand-parse-scs op)
1210 (compute-loading-costs op load-p)
1211 (values *no-costs* *no-loads*)))
1213 (defun compute-costs-and-restrictions-list (ops load-p)
1214 (declare (list ops))
1218 (multiple-value-bind (costs scs) (compute-loading-costs-if-any op load-p)
1221 (values (costs) (scs))))
1223 (defun make-costs-and-restrictions (parse)
1224 (multiple-value-bind (arg-costs arg-scs)
1225 (compute-costs-and-restrictions-list (vop-parse-args parse) t)
1226 (multiple-value-bind (result-costs result-scs)
1227 (compute-costs-and-restrictions-list (vop-parse-results parse) nil)
1229 :cost ,(vop-parse-cost parse)
1231 :arg-costs ',arg-costs
1232 :arg-load-scs ',arg-scs
1233 :result-costs ',result-costs
1234 :result-load-scs ',result-scs
1237 ',(if (vop-parse-more-args parse)
1238 (compute-loading-costs-if-any (vop-parse-more-args parse) t)
1242 ',(if (vop-parse-more-results parse)
1243 (compute-loading-costs-if-any (vop-parse-more-results parse) nil)
1246 ;;;; operand checking and stuff
1248 ;;; Given a list of arg/result restrictions, check for valid syntax
1249 ;;; and convert to canonical form.
1250 (defun !parse-vop-operand-types (specs args-p)
1251 (declare (list specs))
1252 (labels ((parse-operand-type (spec)
1253 (cond ((eq spec '*) spec)
1255 (let ((alias (gethash spec
1256 *backend-primitive-type-aliases*)))
1258 (parse-operand-type alias)
1261 (error "bad thing to be a operand type: ~S" spec))
1265 (collect ((results))
1267 (dolist (item (cdr spec))
1268 (unless (symbolp item)
1269 (error "bad PRIMITIVE-TYPE name in ~S: ~S"
1273 *backend-primitive-type-aliases*)))
1275 (let ((alias (parse-operand-type alias)))
1276 (unless (eq (car alias) :or)
1277 (error "can't include primitive-type ~
1278 alias ~S in an :OR restriction: ~S"
1280 (dolist (x (cdr alias))
1283 (remove-duplicates (results)
1288 (error "can't :CONSTANT for a result"))
1289 (unless (= (length spec) 2)
1290 (error "bad :CONSTANT argument type spec: ~S" spec))
1293 (error "bad thing to be a operand type: ~S" spec)))))))
1294 (mapcar #'parse-operand-type specs)))
1296 ;;; Check the consistency of OP's SC restrictions with the specified
1297 ;;; primitive-type restriction. :CONSTANT operands have already been
1298 ;;; filtered out, so only :OR and * restrictions are left.
1300 ;;; We check that every representation allowed by the type can be
1301 ;;; directly loaded into some SC in the restriction, and that the type
1302 ;;; allows every SC in the restriction. With *, we require that T
1303 ;;; satisfy the first test, and omit the second.
1304 (defun check-operand-type-scs (parse op type load-p)
1305 (declare (type vop-parse parse) (type operand-parse op))
1306 (let ((ptypes (if (eq type '*) (list t) (rest type)))
1307 (scs (operand-parse-scs op)))
1309 (multiple-value-bind (costs load-scs) (compute-loading-costs op load-p)
1310 (declare (ignore costs))
1311 (dolist (ptype ptypes)
1312 (unless (dolist (rep (primitive-type-scs
1313 (meta-primitive-type-or-lose ptype))
1315 (when (svref load-scs rep) (return t)))
1316 (error "In the ~A ~:[result~;argument~] to VOP ~S,~@
1317 none of the SCs allowed by the operand type ~S can ~
1318 directly be loaded~@
1319 into any of the restriction's SCs:~% ~S~:[~;~@
1320 [* type operand must allow T's SCs.]~]"
1321 (operand-parse-name op) load-p (vop-parse-name parse)
1323 scs (eq type '*)))))
1326 (unless (or (eq type '*)
1327 (dolist (ptype ptypes nil)
1328 (when (meta-sc-allowed-by-primitive-type
1329 (meta-sc-or-lose sc)
1330 (meta-primitive-type-or-lose ptype))
1332 (warn "~:[Result~;Argument~] ~A to VOP ~S~@
1333 has SC restriction ~S which is ~
1334 not allowed by the operand type:~% ~S"
1335 load-p (operand-parse-name op) (vop-parse-name parse)
1340 ;;; If the operand types are specified, then check the number specified
1341 ;;; against the number of defined operands.
1342 (defun check-operand-types (parse ops more-op types load-p)
1343 (declare (type vop-parse parse) (list ops)
1344 (type (or list (member :unspecified)) types)
1345 (type (or operand-parse null) more-op))
1346 (unless (eq types :unspecified)
1347 (let ((num (+ (length ops) (if more-op 1 0))))
1348 (unless (= (count-if-not (lambda (x)
1350 (eq (car x) :constant)))
1353 (error "expected ~W ~:[result~;argument~] type~P: ~S"
1354 num load-p types num)))
1357 (let ((mtype (car (last types))))
1358 (when (and (consp mtype) (eq (first mtype) :constant))
1359 (error "can't use :CONSTANT on VOP more args")))))
1361 (when (vop-parse-translate parse)
1362 (let ((types (specify-operand-types types ops more-op)))
1364 (check-operand-type-scs parse x y load-p))
1365 (if more-op (butlast ops) ops)
1366 (remove-if (lambda (x)
1368 (eq (car x) ':constant)))
1369 (if more-op (butlast types) types)))))
1373 ;;; Compute stuff that can only be computed after we are done parsing
1374 ;;; everying. We set the VOP-PARSE-OPERANDS, and do various error checks.
1375 (defun !grovel-vop-operands (parse)
1376 (declare (type vop-parse parse))
1378 (setf (vop-parse-operands parse)
1379 (append (vop-parse-args parse)
1380 (if (vop-parse-more-args parse)
1381 (list (vop-parse-more-args parse)))
1382 (vop-parse-results parse)
1383 (if (vop-parse-more-results parse)
1384 (list (vop-parse-more-results parse)))
1385 (vop-parse-temps parse)))
1387 (check-operand-types parse
1388 (vop-parse-args parse)
1389 (vop-parse-more-args parse)
1390 (vop-parse-arg-types parse)
1393 (check-operand-types parse
1394 (vop-parse-results parse)
1395 (vop-parse-more-results parse)
1396 (vop-parse-result-types parse)
1401 ;;;; function translation stuff
1403 ;;; Return forms to establish this VOP as a IR2 translation template
1404 ;;; for the :TRANSLATE functions specified in the VOP-PARSE. We also
1405 ;;; set the PREDICATE attribute for each translated function when the
1406 ;;; VOP is conditional, causing IR1 conversion to ensure that a call
1407 ;;; to the translated is always used in a predicate position.
1408 (defun !set-up-fun-translation (parse n-template)
1409 (declare (type vop-parse parse))
1410 (mapcar (lambda (name)
1411 `(let ((info (fun-info-or-lose ',name)))
1412 (setf (fun-info-templates info)
1413 (adjoin-template ,n-template (fun-info-templates info)))
1414 ,@(when (vop-parse-conditional-p parse)
1415 '((setf (fun-info-attributes info)
1417 (ir1-attributes predicate)
1418 (fun-info-attributes info)))))))
1419 (vop-parse-translate parse)))
1421 ;;; Return a form that can be evaluated to get the TEMPLATE operand type
1422 ;;; restriction from the given specification.
1423 (defun make-operand-type (type)
1424 (cond ((eq type '*) ''*)
1426 ``(:or ,(primitive-type-or-lose ',type)))
1430 ``(:or ,,@(mapcar (lambda (type)
1431 `(primitive-type-or-lose ',type))
1434 ``(:constant ,#'(lambda (x)
1435 (typep x ',(second type)))
1436 ,',(second type)))))))
1438 (defun specify-operand-types (types ops more-ops)
1439 (if (eq types :unspecified)
1440 (make-list (+ (length ops) (if more-ops 1 0)) :initial-element '*)
1443 ;;; Return a list of forms to use as &KEY args to MAKE-VOP-INFO for
1444 ;;; setting up the template argument and result types. Here we make an
1445 ;;; initial dummy TEMPLATE-TYPE, since it is awkward to compute the
1446 ;;; type until the template has been made.
1447 (defun make-vop-info-types (parse)
1448 (let* ((more-args (vop-parse-more-args parse))
1449 (all-args (specify-operand-types (vop-parse-arg-types parse)
1450 (vop-parse-args parse)
1452 (args (if more-args (butlast all-args) all-args))
1453 (more-arg (when more-args (car (last all-args))))
1454 (more-results (vop-parse-more-results parse))
1455 (all-results (specify-operand-types (vop-parse-result-types parse)
1456 (vop-parse-results parse)
1458 (results (if more-results (butlast all-results) all-results))
1459 (more-result (when more-results (car (last all-results))))
1460 (conditional (vop-parse-conditional-p parse)))
1462 `(:type (specifier-type '(function () nil))
1463 :arg-types (list ,@(mapcar #'make-operand-type args))
1464 :more-args-type ,(when more-args (make-operand-type more-arg))
1465 :result-types ,(cond ((eq conditional t)
1468 `'(:conditional . ,conditional))
1470 `(list ,@(mapcar #'make-operand-type results))))
1471 :more-results-type ,(when more-results
1472 (make-operand-type more-result)))))
1474 ;;;; setting up VOP-INFO
1476 (eval-when (:compile-toplevel :load-toplevel :execute)
1477 (defparameter *slot-inherit-alist*
1478 '((:generator-function . vop-info-generator-function))))
1480 ;;; This is something to help with inheriting VOP-INFO slots. We
1481 ;;; return a keyword/value pair that can be passed to the constructor.
1482 ;;; SLOT is the keyword name of the slot, Parse is a form that
1483 ;;; evaluates to the VOP-PARSE structure for the VOP inherited. If
1484 ;;; PARSE is NIL, then we do nothing. If the TEST form evaluates to
1485 ;;; true, then we return a form that selects the named slot from the
1486 ;;; VOP-INFO structure corresponding to PARSE. Otherwise, we return
1487 ;;; the FORM so that the slot is recomputed.
1488 (defmacro inherit-vop-info (slot parse test form)
1489 `(if (and ,parse ,test)
1490 (list ,slot `(,',(or (cdr (assoc slot *slot-inherit-alist*))
1491 (error "unknown slot ~S" slot))
1492 (template-or-lose ',(vop-parse-name ,parse))))
1493 (list ,slot ,form)))
1495 ;;; Return a form that creates a VOP-INFO structure which describes VOP.
1496 (defun set-up-vop-info (iparse parse)
1497 (declare (type vop-parse parse) (type (or vop-parse null) iparse))
1498 (let ((same-operands
1500 (equal (vop-parse-operands parse)
1501 (vop-parse-operands iparse))
1502 (equal (vop-parse-info-args iparse)
1503 (vop-parse-info-args parse))))
1504 (variant (vop-parse-variant parse)))
1506 (let ((nvars (length (vop-parse-variant-vars parse))))
1507 (unless (= (length variant) nvars)
1508 (error "expected ~W variant values: ~S" nvars variant)))
1511 :name ',(vop-parse-name parse)
1512 ,@(make-vop-info-types parse)
1513 :guard ,(when (vop-parse-guard parse)
1514 `(lambda () ,(vop-parse-guard parse)))
1515 :note ',(vop-parse-note parse)
1516 :info-arg-count ,(length (vop-parse-info-args parse))
1517 :ltn-policy ',(vop-parse-ltn-policy parse)
1518 :save-p ',(vop-parse-save-p parse)
1519 :move-args ',(vop-parse-move-args parse)
1520 :effects (vop-attributes ,@(vop-parse-effects parse))
1521 :affected (vop-attributes ,@(vop-parse-affected parse))
1522 ,@(make-costs-and-restrictions parse)
1523 ,@(make-emit-function-and-friends parse)
1524 ,@(inherit-vop-info :generator-function iparse
1526 (equal (vop-parse-body parse) (vop-parse-body iparse)))
1527 (unless (eq (vop-parse-body parse) :unspecified)
1528 (make-generator-function parse)))
1529 :variant (list ,@variant))))
1531 ;;; Define the symbol NAME to be a Virtual OPeration in the compiler.
1532 ;;; If specified, INHERITS is the name of a VOP that we default
1533 ;;; unspecified information from. Each SPEC is a list beginning with a
1534 ;;; keyword indicating the interpretation of the other forms in the
1537 ;;; :ARGS {(Name {Key Value}*)}*
1538 ;;; :RESULTS {(Name {Key Value}*)}*
1539 ;;; The Args and Results are specifications of the operand TNs passed
1540 ;;; to the VOP. If there is an inherited VOP, any unspecified options
1541 ;;; are defaulted from the inherited argument (or result) of the same
1542 ;;; name. The following operand options are defined:
1545 ;;; :SCs specifies good SCs for this operand. Other SCs will
1546 ;;; be penalized according to move costs. A load TN will be
1547 ;;; allocated if necessary, guaranteeing that the operand is
1548 ;;; always one of the specified SCs.
1550 ;;; :LOAD-TN Load-Name
1551 ;;; Load-Name is bound to the load TN allocated for this
1552 ;;; operand, or to NIL if no load TN was allocated.
1554 ;;; :LOAD-IF EXPRESSION
1555 ;;; Controls whether automatic operand loading is done.
1556 ;;; EXPRESSION is evaluated with the fixed operand TNs bound.
1557 ;;; If EXPRESSION is true,then loading is done and the variable
1558 ;;; is bound to the load TN in the generator body. Otherwise,
1559 ;;; loading is not done, and the variable is bound to the actual
1563 ;;; If specified, NAME is bound to the TN-REF for the first
1564 ;;; argument or result following the fixed arguments or results.
1565 ;;; A :MORE operand must appear last, and cannot be targeted or
1569 ;;; This operand is targeted to the named operand, indicating a
1570 ;;; desire to pack in the same location. Not legal for results.
1574 ;;; Specify the beginning or end of the operand's lifetime.
1575 ;;; :FROM can only be used with results, and :TO only with
1576 ;;; arguments. The default for the N'th argument/result is
1577 ;;; (:ARGUMENT N)/(:RESULT N). These options are necessary
1578 ;;; primarily when operands are read or written out of order.
1580 ;;; :CONDITIONAL [Condition-descriptor+]
1581 ;;; This is used in place of :RESULTS with conditional branch VOPs.
1582 ;;; There are no result values: the result is a transfer of control.
1583 ;;; The target label is passed as the first :INFO arg. The second
1584 ;;; :INFO arg is true if the sense of the test should be negated.
1585 ;;; A side effect is to set the PREDICATE attribute for functions
1586 ;;; in the :TRANSLATE option.
1588 ;;; If some condition descriptors are provided, this is a flag-setting
1589 ;;; VOP. Descriptors are interpreted in an architecture-dependent
1590 ;;; manner. See the BRANCH-IF VOP in $ARCH/pred.lisp.
1592 ;;; :TEMPORARY ({Key Value}*) Name*
1593 ;;; Allocate a temporary TN for each Name, binding that variable to
1594 ;;; the TN within the body of the generators. In addition to :TARGET
1595 ;;; (which is is the same as for operands), the following options are
1599 ;;; :OFFSET SB-Offset
1600 ;;; Force the temporary to be allocated in the specified SC
1601 ;;; with the specified offset. Offset is evaluated at
1602 ;;; macroexpand time. If Offset is omitted, the register
1603 ;;; allocator chooses a free location in SC. If both SC and
1604 ;;; Offset are omitted, then the temporary is packed according
1605 ;;; to its primitive type.
1609 ;;; Similar to the argument/result option, this specifies the
1610 ;;; start and end of the temporaries' lives. The defaults are
1611 ;;; :LOAD and :SAVE, i.e. the duration of the VOP. The other
1612 ;;; intervening phases are :ARGUMENT, :EVAL and :RESULT.
1613 ;;; Non-zero sub-phases can be specified by a list, e.g. by
1614 ;;; default the second argument's life ends at (:ARGUMENT 1).
1616 ;;; :GENERATOR Cost Form*
1617 ;;; Specifies the translation into assembly code. Cost is the
1618 ;;; estimated cost of the code emitted by this generator. The body
1619 ;;; is arbitrary Lisp code that emits the assembly language
1620 ;;; translation of the VOP. An ASSEMBLE form is wrapped around
1621 ;;; the body, so code may be emitted by using the local INST macro.
1622 ;;; During the evaluation of the body, the names of the operands
1623 ;;; and temporaries are bound to the actual TNs.
1625 ;;; :EFFECTS Effect*
1626 ;;; :AFFECTED Effect*
1627 ;;; Specifies the side effects that this VOP has and the side
1628 ;;; effects that effect its execution. If unspecified, these
1629 ;;; default to the worst case.
1632 ;;; Define some magic arguments that are passed directly to the code
1633 ;;; generator. The corresponding trailing arguments to VOP or
1634 ;;; %PRIMITIVE are stored in the VOP structure. Within the body
1635 ;;; of the generators, the named variables are bound to these
1636 ;;; values. Except in the case of :CONDITIONAL VOPs, :INFO arguments
1637 ;;; cannot be specified for VOPS that are the direct translation
1638 ;;; for a function (specified by :TRANSLATE).
1641 ;;; Causes the named variables to be declared IGNORE in the
1645 ;;; :VARIANT-VARS Name*
1646 ;;; These options provide a way to parameterize families of VOPs
1647 ;;; that differ only trivially. :VARIANT makes the specified
1648 ;;; evaluated Things be the "variant" associated with this VOP.
1649 ;;; :VARIANT-VARS causes the named variables to be bound to the
1650 ;;; corresponding Things within the body of the generator.
1652 ;;; :VARIANT-COST Cost
1653 ;;; Specifies the cost of this VOP, overriding the cost of any
1654 ;;; inherited generator.
1656 ;;; :NOTE {String | NIL}
1657 ;;; A short noun-like phrase describing what this VOP "does", i.e.
1658 ;;; the implementation strategy. If supplied, efficiency notes will
1659 ;;; be generated when type uncertainty prevents :TRANSLATE from
1660 ;;; working. NIL inhibits any efficiency note.
1662 ;;; :ARG-TYPES {* | PType | (:OR PType*) | (:CONSTANT Type)}*
1663 ;;; :RESULT-TYPES {* | PType | (:OR PType*)}*
1664 ;;; Specify the template type restrictions used for automatic
1665 ;;; translation. If there is a :MORE operand, the last type is the
1666 ;;; more type. :CONSTANT specifies that the argument must be a
1667 ;;; compile-time constant of the specified Lisp type. The constant
1668 ;;; values of :CONSTANT arguments are passed as additional :INFO
1669 ;;; arguments rather than as :ARGS.
1671 ;;; :TRANSLATE Name*
1672 ;;; This option causes the VOP template to be entered as an IR2
1673 ;;; translation for the named functions.
1675 ;;; :POLICY {:SMALL | :FAST | :SAFE | :FAST-SAFE}
1676 ;;; Specifies the policy under which this VOP is the best translation.
1679 ;;; Specifies a Form that is evaluated in the global environment.
1680 ;;; If form returns NIL, then emission of this VOP is prohibited
1681 ;;; even when all other restrictions are met.
1685 ;;; In the generator, bind the specified variable to the VOP or
1686 ;;; the Node that generated this VOP.
1688 ;;; :SAVE-P {NIL | T | :COMPUTE-ONLY | :FORCE-TO-STACK}
1689 ;;; Indicates how a VOP wants live registers saved.
1691 ;;; :MOVE-ARGS {NIL | :FULL-CALL | :LOCAL-CALL | :KNOWN-RETURN}
1692 ;;; Indicates if and how the more args should be moved into a
1693 ;;; different frame.
1694 (def!macro define-vop ((name &optional inherits) &body specs)
1695 (declare (type symbol name))
1696 ;; Parse the syntax into a VOP-PARSE structure, and then expand into
1697 ;; code that creates the appropriate VOP-INFO structure at load time.
1698 ;; We implement inheritance by copying the VOP-PARSE structure for
1699 ;; the inherited structure.
1700 (let* ((inherited-parse (when inherits
1701 (vop-parse-or-lose inherits)))
1703 (copy-vop-parse inherited-parse)
1706 (setf (vop-parse-name parse) name)
1707 (setf (vop-parse-inherits parse) inherits)
1709 (parse-define-vop parse specs)
1710 (!grovel-vop-operands parse)
1713 (eval-when (:compile-toplevel :load-toplevel :execute)
1714 (setf (gethash ',name *backend-parsed-vops*)
1717 (let ((,n-res ,(set-up-vop-info inherited-parse parse)))
1718 (setf (gethash ',name *backend-template-names*) ,n-res)
1719 (setf (template-type ,n-res)
1720 (specifier-type (template-type-specifier ,n-res)))
1721 ,@(!set-up-fun-translation parse n-res))
1724 ;;;; emission macros
1726 ;;; Return code to make a list of VOP arguments or results, linked by
1727 ;;; TN-REF-ACROSS. The first value is code, the second value is LET*
1728 ;;; forms, and the third value is a variable that evaluates to the
1729 ;;; head of the list, or NIL if there are no operands. Fixed is a list
1730 ;;; of forms that evaluate to TNs for the fixed operands. TN-REFS will
1731 ;;; be made for these operands according using the specified value of
1732 ;;; WRITE-P. More is an expression that evaluates to a list of TN-REFS
1733 ;;; that will be made the tail of the list. If it is constant NIL,
1734 ;;; then we don't bother to set the tail.
1735 (defun make-operand-list (fixed more write-p)
1741 (let ((n-ref (gensym)))
1742 (binds `(,n-ref (reference-tn ,op ,write-p)))
1744 (forms `(setf (tn-ref-across ,n-prev) ,n-ref))
1745 (setq n-head n-ref))
1746 (setq n-prev n-ref)))
1749 (let ((n-more (gensym)))
1750 (binds `(,n-more ,more))
1752 (forms `(setf (tn-ref-across ,n-prev) ,n-more))
1753 (setq n-head n-more))))
1755 (values (forms) (binds) n-head))))
1757 ;;; Emit-Template Node Block Template Args Results [Info]
1759 ;;; Call the emit function for TEMPLATE, linking the result in at the
1761 (defmacro emit-template (node block template args results &optional info)
1762 (let ((n-first (gensym))
1764 (once-only ((n-node node)
1766 (n-template template))
1767 `(multiple-value-bind (,n-first ,n-last)
1768 (funcall (template-emit-function ,n-template)
1769 ,n-node ,n-block ,n-template ,args ,results
1770 ,@(when info `(,info)))
1771 (insert-vop-sequence ,n-first ,n-last ,n-block nil)))))
1773 ;;; VOP Name Node Block Arg* Info* Result*
1775 ;;; Emit the VOP (or other template) NAME at the end of the IR2-BLOCK
1776 ;;; BLOCK, using NODE for the source context. The interpretation of
1777 ;;; the remaining arguments depends on the number of operands of
1778 ;;; various kinds that are declared in the template definition. VOP
1779 ;;; cannot be used for templates that have more-args or more-results,
1780 ;;; since the number of arguments and results is indeterminate for
1781 ;;; these templates. Use VOP* instead.
1783 ;;; ARGS and RESULTS are the TNs that are to be referenced by the
1784 ;;; template as arguments and results. If the template has
1785 ;;; codegen-info arguments, then the appropriate number of INFO forms
1786 ;;; following the arguments are used for codegen info.
1787 (defmacro vop (name node block &rest operands)
1788 (let* ((parse (vop-parse-or-lose name))
1789 (arg-count (length (vop-parse-args parse)))
1790 (result-count (length (vop-parse-results parse)))
1791 (info-count (length (vop-parse-info-args parse)))
1792 (noperands (+ arg-count result-count info-count))
1795 (n-template (gensym)))
1797 (when (or (vop-parse-more-args parse) (vop-parse-more-results parse))
1798 (error "cannot use VOP with variable operand count templates"))
1799 (unless (= noperands (length operands))
1800 (error "called with ~W operands, but was expecting ~W"
1801 (length operands) noperands))
1803 (multiple-value-bind (acode abinds n-args)
1804 (make-operand-list (subseq operands 0 arg-count) nil nil)
1805 (multiple-value-bind (rcode rbinds n-results)
1806 (make-operand-list (subseq operands (+ arg-count info-count)) nil t)
1810 (dolist (info (subseq operands arg-count (+ arg-count info-count)))
1811 (let ((temp (gensym)))
1812 (ibinds `(,temp ,info))
1815 `(let* ((,n-node ,node)
1817 (,n-template (template-or-lose ',name))
1823 (emit-template ,n-node ,n-block ,n-template ,n-args
1826 `((list ,@(ivars)))))
1829 ;;; VOP* Name Node Block (Arg* More-Args) (Result* More-Results) Info*
1831 ;;; This is like VOP, but allows for emission of templates with
1832 ;;; arbitrary numbers of arguments, and for emission of templates
1833 ;;; using already-created TN-REF lists.
1835 ;;; The ARGS and RESULTS are TNs to be referenced as the first
1836 ;;; arguments and results to the template. More-Args and More-Results
1837 ;;; are heads of TN-REF lists that are added onto the end of the
1838 ;;; TN-REFS for the explicitly supplied operand TNs. The TN-REFS for
1839 ;;; the more operands must have the TN and WRITE-P slots correctly
1842 ;;; As with VOP, the INFO forms are evaluated and passed as codegen
1844 (defmacro vop* (name node block args results &rest info)
1845 (declare (type cons args results))
1846 (let* ((parse (vop-parse-or-lose name))
1847 (arg-count (length (vop-parse-args parse)))
1848 (result-count (length (vop-parse-results parse)))
1849 (info-count (length (vop-parse-info-args parse)))
1850 (fixed-args (butlast args))
1851 (fixed-results (butlast results))
1854 (n-template (gensym)))
1856 (unless (or (vop-parse-more-args parse)
1857 (<= (length fixed-args) arg-count))
1858 (error "too many fixed arguments"))
1859 (unless (or (vop-parse-more-results parse)
1860 (<= (length fixed-results) result-count))
1861 (error "too many fixed results"))
1862 (unless (= (length info) info-count)
1863 (error "expected ~W info args" info-count))
1865 (multiple-value-bind (acode abinds n-args)
1866 (make-operand-list fixed-args (car (last args)) nil)
1867 (multiple-value-bind (rcode rbinds n-results)
1868 (make-operand-list fixed-results (car (last results)) t)
1870 `(let* ((,n-node ,node)
1872 (,n-template (template-or-lose ',name))
1877 (emit-template ,n-node ,n-block ,n-template ,n-args ,n-results
1882 ;;;; miscellaneous macros
1884 ;;; SC-Case TN {({(SC-Name*) | SC-Name | T} Form*)}*
1886 ;;; Case off of TN's SC. The first clause containing TN's SC is
1887 ;;; evaluated, returning the values of the last form. A clause
1888 ;;; beginning with T specifies a default. If it appears, it must be
1889 ;;; last. If no default is specified, and no clause matches, then an
1890 ;;; error is signalled.
1891 (def!macro sc-case (tn &body forms)
1892 (let ((n-sc (gensym))
1894 (collect ((clauses))
1895 (do ((cases forms (rest cases)))
1897 (clauses `(t (error "unknown SC to SC-CASE for ~S:~% ~S" ,n-tn
1898 (sc-name (tn-sc ,n-tn))))))
1899 (let ((case (first cases)))
1901 (error "illegal SC-CASE clause: ~S" case))
1902 (let ((head (first case)))
1905 (error "T case is not last in SC-CASE."))
1906 (clauses `(t nil ,@(rest case)))
1908 (clauses `((or ,@(mapcar (lambda (x)
1909 `(eql ,(meta-sc-number-or-lose x)
1911 (if (atom head) (list head) head)))
1912 nil ,@(rest case))))))
1915 (,n-sc (sc-number (tn-sc ,n-tn))))
1916 (cond ,@(clauses))))))
1918 ;;; Return true if TNs SC is any of the named SCs, false otherwise.
1919 (defmacro sc-is (tn &rest scs)
1920 (once-only ((n-sc `(sc-number (tn-sc ,tn))))
1921 `(or ,@(mapcar (lambda (x)
1922 `(eql ,n-sc ,(meta-sc-number-or-lose x)))
1925 ;;; Iterate over the IR2 blocks in component, in emission order.
1926 (defmacro do-ir2-blocks ((block-var component &optional result)
1928 `(do ((,block-var (block-info (component-head ,component))
1929 (ir2-block-next ,block-var)))
1930 ((null ,block-var) ,result)
1933 ;;; Iterate over all the TNs live at some point, with the live set
1934 ;;; represented by a local conflicts bit-vector and the IR2-BLOCK
1935 ;;; containing the location.
1936 (defmacro do-live-tns ((tn-var live block &optional result) &body body)
1937 (let ((n-conf (gensym))
1941 (once-only ((n-live live)
1944 (flet ((,n-bod (,tn-var) ,@body))
1945 ;; Do component-live TNs.
1946 (dolist (,tn-var (ir2-component-component-tns
1949 (ir2-block-block ,n-block)))))
1952 (let ((,ltns (ir2-block-local-tns ,n-block)))
1953 ;; Do TNs always-live in this block and live :MORE TNs.
1954 (do ((,n-conf (ir2-block-global-tns ,n-block)
1955 (global-conflicts-next-blockwise ,n-conf)))
1957 (when (or (eq (global-conflicts-kind ,n-conf) :live)
1958 (let ((,i (global-conflicts-number ,n-conf)))
1959 (and (eq (svref ,ltns ,i) :more)
1960 (not (zerop (sbit ,n-live ,i))))))
1961 (,n-bod (global-conflicts-tn ,n-conf))))
1962 ;; Do TNs locally live in the designated live set.
1963 (dotimes (,i (ir2-block-local-tn-count ,n-block) ,result)
1964 (unless (zerop (sbit ,n-live ,i))
1965 (let ((,tn-var (svref ,ltns ,i)))
1966 (when (and ,tn-var (not (eq ,tn-var :more)))
1967 (,n-bod ,tn-var)))))))))))
1969 ;;; Iterate over all the IR2 blocks in PHYSENV, in emit order.
1970 (defmacro do-physenv-ir2-blocks ((block-var physenv &optional result)
1972 (once-only ((n-physenv physenv))
1973 (once-only ((n-first `(lambda-block (physenv-lambda ,n-physenv))))
1974 (once-only ((n-tail `(block-info
1976 (block-component ,n-first)))))
1977 `(do ((,block-var (block-info ,n-first)
1978 (ir2-block-next ,block-var)))
1979 ((or (eq ,block-var ,n-tail)
1980 (not (eq (ir2-block-physenv ,block-var) ,n-physenv)))