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
394 ;; argument and result primitive types. These are pulled out of the
395 ;; operands, since we often want to change them without respecifying
397 (arg-types :unspecified
:type
(or (member :unspecified
) list
))
398 (result-types :unspecified
:type
(or (member :unspecified
) list
))
399 ;; the guard expression specified, or NIL if none
401 ;; the cost of and body code for the generator
402 (cost 0 :type unsigned-byte
)
403 (body :unspecified
:type
(or (member :unspecified
) list
))
404 ;; info for VOP variants. The list of forms to be evaluated to get
405 ;; the variant args for this VOP, and the list of variables to be
406 ;; bound to the variant args.
407 (variant () :type list
)
408 (variant-vars () :type list
)
409 ;; variables bound to the VOP and Vop-Node when in the generator body
410 (vop-var '.vop.
:type symbol
)
411 (node-var nil
:type
(or symbol null
))
412 ;; a list of the names of the codegen-info arguments to this VOP
413 (info-args () :type list
)
414 ;; an efficiency note associated with this VOP
415 (note nil
:type
(or string null
))
416 ;; a list of the names of the Effects and Affected attributes for
418 (effects '(any) :type list
)
419 (affected '(any) :type list
)
420 ;; a list of the names of functions this VOP is a translation of and
421 ;; the policy that allows this translation to be done. :FAST is a
422 ;; safe default, since it isn't a safe policy.
423 (translate () :type list
)
424 (ltn-policy :fast
:type ltn-policy
)
425 ;; stuff used by life analysis
426 (save-p nil
:type
(member t nil
:compute-only
:force-to-stack
))
427 ;; info about how to emit MOVE-ARG VOPs for the &MORE operand in
429 (move-args nil
:type
(member nil
:local-call
:full-call
:known-return
)))
430 (defprinter (vop-parse)
432 (inherits :test inherits
)
436 (more-args :test more-args
)
437 (more-results :test more-results
)
438 (conditional-p :test conditional-p
)
444 (variant :test variant
)
445 (variant-vars :test variant-vars
)
446 (info-args :test info-args
)
452 (save-p :test save-p
)
453 (move-args :test move-args
))
455 ;;; An OPERAND-PARSE object contains stuff we need to know about an
456 ;;; operand or temporary at meta-compile time. Besides the obvious
457 ;;; stuff, we also store the names of per-operand temporaries here.
458 (def!struct
(operand-parse
459 (:make-load-form-fun just-dump-it-normally
)
460 #-sb-xc-host
(:pure t
))
461 ;; name of the operand (which we bind to the TN)
462 (name nil
:type symbol
)
463 ;; the way this operand is used:
465 :type
(member :argument
:result
:temporary
466 :more-argument
:more-result
))
467 ;; If true, the name of an operand that this operand is targeted to.
468 ;; This is only meaningful in :ARGUMENT and :TEMPORARY operands.
469 (target nil
:type
(or symbol null
))
470 ;; TEMP is a temporary that holds the TN-REF for this operand.
471 (temp (make-operand-parse-temp) :type symbol
)
472 ;; the time that this operand is first live and the time at which it
473 ;; becomes dead again. These are TIME-SPECs, as returned by
477 ;; a list of the names of the SCs that this operand is allowed into.
478 ;; If false, there is no restriction.
480 ;; Variable that is bound to the load TN allocated for this operand, or to
481 ;; NIL if no load-TN was allocated.
482 (load-tn (make-operand-parse-load-tn) :type symbol
)
483 ;; an expression that tests whether to do automatic operand loading
485 ;; In a wired or restricted temporary this is the SC the TN is to be
486 ;; packed in. Null otherwise.
487 (sc nil
:type
(or symbol null
))
488 ;; If non-null, we are a temp wired to this offset in SC.
489 (offset nil
:type
(or unsigned-byte null
)))
490 (defprinter (operand-parse)
493 (target :test target
)
499 (offset :test offset
))
501 ;;;; miscellaneous utilities
503 ;;; Find the operand or temporary with the specifed Name in the VOP
504 ;;; Parse. If there is no such operand, signal an error. Also error if
505 ;;; the operand kind isn't one of the specified Kinds. If Error-P is
506 ;;; NIL, just return NIL if there is no such operand.
507 (defun find-operand (name parse
&optional
508 (kinds '(:argument
:result
:temporary
))
510 (declare (symbol name
) (type vop-parse parse
) (list kinds
))
511 (let ((found (find name
(vop-parse-operands parse
)
512 :key
#'operand-parse-name
)))
514 (unless (member (operand-parse-kind found
) kinds
)
515 (error "Operand ~S isn't one of these kinds: ~S." name kinds
))
517 (error "~S is not an operand to ~S." name
(vop-parse-name parse
))))
520 ;;; Get the VOP-PARSE structure for NAME or die trying. For all
521 ;;; meta-compile time uses, the VOP-PARSE should be used instead of
523 (defun vop-parse-or-lose (name)
525 (or (gethash name
*backend-parsed-vops
*)
526 (error "~S is not the name of a defined VOP." name
))))
528 ;;; Return a list of LET-forms to parse a TN-REF list into the temps
529 ;;; specified by the operand-parse structures. MORE-OPERAND is the
530 ;;; OPERAND-PARSE describing any more operand, or NIL if none. REFS is
531 ;;; an expression that evaluates into the first TN-REF.
532 (defun access-operands (operands more-operand refs
)
533 (declare (list operands
))
536 (dolist (op operands
)
537 (let ((n-ref (operand-parse-temp op
)))
538 (res `(,n-ref
,prev
))
539 (setq prev
`(tn-ref-across ,n-ref
))))
542 (res `(,(operand-parse-name more-operand
) ,prev
))))
545 ;;; This is used with ACCESS-OPERANDS to prevent warnings for TN-REF
546 ;;; temps not used by some particular function. It returns the name of
547 ;;; the last operand, or NIL if OPERANDS is NIL.
548 (defun ignore-unreferenced-temps (operands)
550 (operand-parse-temp (car (last operands
)))))
552 ;;; Grab an arg out of a VOP spec, checking the type and syntax and stuff.
553 (defun vop-spec-arg (spec type
&optional
(n 1) (last t
))
554 (let ((len (length spec
)))
556 (error "~:R argument missing: ~S" n spec
))
557 (when (and last
(> len
(1+ n
)))
558 (error "extra junk at end of ~S" spec
))
559 (let ((thing (elt spec n
)))
560 (unless (typep thing type
)
561 (error "~:R argument is not a ~S: ~S" n type spec
))
566 ;;; Return a time spec describing a time during the evaluation of a
567 ;;; VOP, used to delimit operand and temporary lifetimes. The
568 ;;; representation is a cons whose CAR is the number of the evaluation
569 ;;; phase and the CDR is the sub-phase. The sub-phase is 0 in the
570 ;;; :LOAD and :SAVE phases.
571 (defun parse-time-spec (spec)
572 (let ((dspec (if (atom spec
) (list spec
0) spec
)))
573 (unless (and (= (length dspec
) 2)
574 (typep (second dspec
) 'unsigned-byte
))
575 (error "malformed time specifier: ~S" spec
))
577 (cons (case (first dspec
)
584 (error "unknown phase in time specifier: ~S" spec
)))
587 ;;; Return true if the time spec X is the same or later time than Y.
588 (defun time-spec-order (x y
)
589 (or (> (car x
) (car y
))
590 (and (= (car x
) (car y
))
591 (>= (cdr x
) (cdr y
)))))
593 ;;;; generation of emit functions
595 (defun compute-temporaries-description (parse)
596 (let ((temps (vop-parse-temps parse
))
597 (element-type '(unsigned-byte 16)))
599 (let ((results (make-specializable-array
601 :element-type element-type
))
604 (declare (type operand-parse temp
))
605 (let ((sc (operand-parse-sc temp
))
606 (offset (operand-parse-offset temp
)))
608 (setf (aref results index
)
610 (+ (ash offset
(1+ sc-bits
))
611 (ash (meta-sc-number-or-lose sc
) 1)
613 (ash (meta-sc-number-or-lose sc
) 1))))
615 ;; KLUDGE: As in the other COERCEs wrapped around with
616 ;; MAKE-SPECIALIZABLE-ARRAY results in COMPUTE-REF-ORDERING,
617 ;; this coercion could be removed by a sufficiently smart
618 ;; compiler, but I dunno whether Python is that smart. It
619 ;; would be good to check this and help it if it's not smart
620 ;; enough to remove it for itself. However, it's probably not
621 ;; urgent, since the overhead of an extra no-op conversion is
622 ;; unlikely to be large compared to consing and corresponding
623 ;; GC. -- WHN ca. 19990701
624 `(coerce ,results
'(specializable-vector ,element-type
))))))
626 (defun compute-ref-ordering (parse)
627 (let* ((num-args (+ (length (vop-parse-args parse
))
628 (if (vop-parse-more-args parse
) 1 0)))
629 (num-results (+ (length (vop-parse-results parse
))
630 (if (vop-parse-more-results parse
) 1 0)))
632 (collect ((refs) (targets))
633 (dolist (op (vop-parse-operands parse
))
634 (when (operand-parse-target op
)
635 (unless (member (operand-parse-kind op
) '(:argument
:temporary
))
636 (error "cannot target a ~S operand: ~S" (operand-parse-kind op
)
637 (operand-parse-name op
)))
638 (let ((target (find-operand (operand-parse-target op
) parse
639 '(:temporary
:result
))))
640 ;; KLUDGE: These formulas must be consistent with those in
641 ;; %EMIT-GENERIC-VOP, and this is currently maintained by
642 ;; hand. -- WHN 2002-01-30, paraphrasing APD
643 (targets (+ (* index max-vop-tn-refs
)
644 (ecase (operand-parse-kind target
)
646 (+ (position-or-lose target
647 (vop-parse-results parse
))
650 (+ (* (position-or-lose target
651 (vop-parse-temps parse
))
656 (let ((born (operand-parse-born op
))
657 (dies (operand-parse-dies op
)))
658 (ecase (operand-parse-kind op
)
660 (refs (cons (cons dies nil
) index
)))
662 (refs (cons (cons dies nil
) index
)))
664 (refs (cons (cons born t
) index
)))
666 (refs (cons (cons born t
) index
)))
668 (refs (cons (cons dies nil
) index
))
670 (refs (cons (cons born t
) index
))))
672 (let* ((sorted (sort (refs)
674 (let ((x-time (car x
))
676 (if (time-spec-order x-time y-time
)
677 (if (time-spec-order y-time x-time
)
678 (and (not (cdr x
)) (cdr y
))
682 ;; :REF-ORDERING element type
684 ;; KLUDGE: was (MOD #.MAX-VOP-TN-REFS), which is still right
685 (oe-type '(unsigned-byte 8))
686 ;; :TARGETS element-type
688 ;; KLUDGE: was (MOD #.(* MAX-VOP-TN-REFS 2)), which does
689 ;; not correspond to the definition in
690 ;; src/compiler/vop.lisp.
691 (te-type '(unsigned-byte 16))
692 (ordering (make-specializable-array
694 :element-type oe-type
)))
697 (setf (aref ordering index
) (cdr ref
))
699 `(:num-args
,num-args
700 :num-results
,num-results
701 ;; KLUDGE: The (COERCE .. (SPECIALIZABLE-VECTOR ..)) wrapper
702 ;; here around the result returned by
703 ;; MAKE-SPECIALIZABLE-ARRAY above was of course added to
704 ;; help with cross-compilation. "A sufficiently smart
705 ;; compiler" should be able to optimize all this away in the
706 ;; final target Lisp, leaving a single MAKE-ARRAY with no
707 ;; subsequent coercion. However, I don't know whether Python
708 ;; is that smart. (Can it figure out the return type of
709 ;; MAKE-ARRAY? Does it know that COERCE can be optimized
710 ;; away if the input type is known to be the same as the
711 ;; COERCEd-to type?) At some point it would be good to test
712 ;; to see whether this construct is in fact causing run-time
713 ;; overhead, and fix it if so. (Some declarations of the
714 ;; types returned by MAKE-ARRAY might be enough to fix it.)
715 ;; However, it's probably not urgent to fix this, since it's
716 ;; hard to imagine that any overhead caused by calling
717 ;; COERCE and letting it decide to bail out could be large
718 ;; compared to the cost of consing and GCing the vectors in
719 ;; the first place. -- WHN ca. 19990701
720 :ref-ordering
(coerce ',ordering
721 '(specializable-vector ,oe-type
))
723 `(:targets
(coerce ',(targets)
724 '(specializable-vector ,te-type
)))))))))
726 (defun make-emit-function-and-friends (parse)
727 `(:emit-function
#'emit-generic-vop
728 :temps
,(compute-temporaries-description parse
)
729 ,@(compute-ref-ordering parse
)))
731 ;;;; generator functions
733 ;;; Return an alist that translates from lists of SCs we can load OP
734 ;;; from to the move function used for loading those SCs. We quietly
735 ;;; ignore restrictions to :non-packed (constant) and :unbounded SCs,
736 ;;; since we don't load into those SCs.
737 (defun find-move-funs (op load-p
)
739 (dolist (sc-name (operand-parse-scs op
))
740 (let* ((sc (meta-sc-or-lose sc-name
))
742 (load-scs (append (when load-p
743 (sc-constant-scs sc
))
744 (sc-alternate-scs sc
))))
747 (dolist (alt load-scs
)
748 (unless (member (sc-name alt
) (operand-parse-scs op
) :test
#'eq
)
749 (let* ((altn (sc-number alt
))
751 (svref (sc-move-funs sc
) altn
)
752 (svref (sc-move-funs alt
) scn
)))
753 (found (or (assoc alt
(funs) :test
#'member
)
754 (rassoc name
(funs)))))
756 (error "no move function defined to ~:[save~;load~] SC ~S ~
757 ~:[to~;from~] from SC ~S"
758 load-p sc-name load-p
(sc-name alt
)))
761 (unless (eq (cdr found
) name
)
762 (error "can't tell whether to ~:[save~;load~]~@
763 with ~S or ~S when operand is in SC ~S"
764 load-p name
(cdr found
) (sc-name alt
)))
765 (pushnew alt
(car found
)))
767 (funs (cons (list alt
) name
))))))))
768 ((member (sb-kind (sc-sb sc
)) '(:non-packed
:unbounded
)))
770 (error "SC ~S has no alternate~:[~; or constant~] SCs, yet it is~@
771 mentioned in the restriction for operand ~S"
772 sc-name load-p
(operand-parse-name op
))))))
775 ;;; Return a form to load/save the specified operand when it has a
776 ;;; load TN. For any given SC that we can load from, there must be a
777 ;;; unique load function. If all SCs we can load from have the same
778 ;;; move function, then we just call that when there is a load TN. If
779 ;;; there are multiple possible move functions, then we dispatch off
780 ;;; of the operand TN's type to see which move function to use.
781 (defun call-move-fun (parse op load-p
)
782 (let ((funs (find-move-funs op load-p
))
783 (load-tn (operand-parse-load-tn op
)))
785 (let* ((tn `(tn-ref-tn ,(operand-parse-temp op
)))
786 (n-vop (or (vop-parse-vop-var parse
)
787 (setf (vop-parse-vop-var parse
) '.vop.
)))
788 (form (if (rest funs
)
790 ,@(mapcar (lambda (x)
791 `(,(mapcar #'sc-name
(car x
))
793 `(,(cdr x
) ,n-vop
,tn
795 `(,(cdr x
) ,n-vop
,load-tn
799 `(,(cdr (first funs
)) ,n-vop
,tn
,load-tn
)
800 `(,(cdr (first funs
)) ,n-vop
,load-tn
,tn
)))))
801 (if (eq (operand-parse-load op
) t
)
802 `(when ,load-tn
,form
)
803 `(when (eq ,load-tn
,(operand-parse-name op
))
806 (error "load TN allocated, but no move function?~@
807 VM definition is inconsistent, recompile and try again.")))))
809 ;;; Return the TN that we should bind to the operand's var in the
810 ;;; generator body. In general, this involves evaluating the :LOAD-IF
812 (defun decide-to-load (parse op
)
813 (let ((load (operand-parse-load op
))
814 (load-tn (operand-parse-load-tn op
))
815 (temp (operand-parse-temp op
)))
817 `(or ,load-tn
(tn-ref-tn ,temp
))
820 (dolist (x (vop-parse-operands parse
))
821 (when (member (operand-parse-kind x
) '(:argument
:result
))
822 (let ((name (operand-parse-name x
)))
823 (binds `(,name
(tn-ref-tn ,(operand-parse-temp x
))))
827 (declare (ignorable ,@(ignores)))
830 (tn-ref-tn ,temp
))))))
832 ;;; Make a lambda that parses the VOP TN-REFS, does automatic operand
833 ;;; loading, and runs the appropriate code generator.
834 (defun make-generator-function (parse)
835 (declare (type vop-parse parse
))
836 (let ((n-vop (vop-parse-vop-var parse
))
837 (operands (vop-parse-operands parse
))
838 (n-info (gensym)) (n-variant (gensym)))
842 (dolist (op operands
)
843 (ecase (operand-parse-kind op
)
845 (let ((temp (operand-parse-temp op
))
846 (name (operand-parse-name op
)))
847 (cond ((and (operand-parse-load op
) (operand-parse-scs op
))
848 (binds `(,(operand-parse-load-tn op
)
849 (tn-ref-load-tn ,temp
)))
850 (binds `(,name
,(decide-to-load parse op
)))
851 (if (eq (operand-parse-kind op
) :argument
)
852 (loads (call-move-fun parse op t
))
853 (saves (call-move-fun parse op nil
))))
855 (binds `(,name
(tn-ref-tn ,temp
)))))))
857 (binds `(,(operand-parse-name op
)
858 (tn-ref-tn ,(operand-parse-temp op
)))))
859 ((:more-argument
:more-result
))))
862 (let* (,@(access-operands (vop-parse-args parse
)
863 (vop-parse-more-args parse
)
865 ,@(access-operands (vop-parse-results parse
)
866 (vop-parse-more-results parse
)
867 `(vop-results ,n-vop
))
868 ,@(access-operands (vop-parse-temps parse
) nil
870 ,@(when (vop-parse-info-args parse
)
871 `((,n-info
(vop-codegen-info ,n-vop
))
872 ,@(mapcar (lambda (x) `(,x
(pop ,n-info
)))
873 (vop-parse-info-args parse
))))
874 ,@(when (vop-parse-variant-vars parse
)
875 `((,n-variant
(vop-info-variant (vop-info ,n-vop
)))
876 ,@(mapcar (lambda (x) `(,x
(pop ,n-variant
)))
877 (vop-parse-variant-vars parse
))))
878 ,@(when (vop-parse-node-var parse
)
879 `((,(vop-parse-node-var parse
) (vop-node ,n-vop
))))
881 (declare (ignore ,@(vop-parse-ignores parse
)))
883 (sb!assem
:assemble
(*code-segment
* ,n-vop
)
884 ,@(vop-parse-body parse
))
887 (defvar *parse-vop-operand-count
*)
888 (defun make-operand-parse-temp ()
889 (without-package-locks
890 (intern (format nil
"OPERAND-PARSE-TEMP-~D" *parse-vop-operand-count
*)
891 (symbol-package '*parse-vop-operand-count
*))))
892 (defun make-operand-parse-load-tn ()
893 (without-package-locks
894 (intern (format nil
"OPERAND-PARSE-LOAD-TN-~D" *parse-vop-operand-count
*)
895 (symbol-package '*parse-vop-operand-count
*))))
897 ;;; Given a list of operand specifications as given to DEFINE-VOP,
898 ;;; return a list of OPERAND-PARSE structures describing the fixed
899 ;;; operands, and a single OPERAND-PARSE describing any more operand.
900 ;;; If we are inheriting a VOP, we default attributes to the inherited
901 ;;; operand of the same name.
902 (defun !parse-vop-operands
(parse specs kind
)
903 (declare (list specs
)
904 (type (member :argument
:result
) kind
))
907 (collect ((operands))
909 (unless (and (consp spec
) (symbolp (first spec
)) (oddp (length spec
)))
910 (error "malformed operand specifier: ~S" spec
))
912 (error "The MORE operand isn't the last operand: ~S" specs
))
913 (incf *parse-vop-operand-count
*)
914 (let* ((name (first spec
))
915 (old (if (vop-parse-inherits parse
)
918 (vop-parse-inherits parse
))
926 :target
(operand-parse-target old
)
927 :born
(operand-parse-born old
)
928 :dies
(operand-parse-dies old
)
929 :scs
(operand-parse-scs old
)
930 :load-tn
(operand-parse-load-tn old
)
931 :load
(operand-parse-load old
))
937 :born
(parse-time-spec :load
)
938 :dies
(parse-time-spec `(:argument
,(incf num
)))))
943 :born
(parse-time-spec `(:result
,(incf num
)))
944 :dies
(parse-time-spec :save
)))))))
945 (do ((key (rest spec
) (cddr key
)))
947 (let ((value (second key
)))
950 (aver (typep value
'list
))
951 (setf (operand-parse-scs res
) (remove-duplicates value
)))
953 (aver (typep value
'symbol
))
954 (setf (operand-parse-load-tn res
) value
))
956 (setf (operand-parse-load res
) value
))
958 (aver (typep value
'boolean
))
959 (setf (operand-parse-kind res
)
960 (if (eq kind
:argument
) :more-argument
:more-result
))
961 (setf (operand-parse-load res
) nil
)
964 (aver (typep value
'symbol
))
965 (setf (operand-parse-target res
) value
))
967 (unless (eq kind
:result
)
968 (error "can only specify :FROM in a result: ~S" spec
))
969 (setf (operand-parse-born res
) (parse-time-spec value
)))
971 (unless (eq kind
:argument
)
972 (error "can only specify :TO in an argument: ~S" spec
))
973 (setf (operand-parse-dies res
) (parse-time-spec value
)))
975 (error "unknown keyword in operand specifier: ~S" spec
)))))
979 ((operand-parse-target more
)
980 (error "cannot specify :TARGET in a :MORE operand"))
981 ((operand-parse-load more
)
982 (error "cannot specify :LOAD-IF in a :MORE operand")))))
983 (values (the list
(operands)) more
))))
985 ;;; Parse a temporary specification, putting the OPERAND-PARSE
986 ;;; structures in the PARSE structure.
987 (defun parse-temporary (spec parse
)
989 (type vop-parse parse
))
990 (let ((len (length spec
)))
992 (error "malformed temporary spec: ~S" spec
))
993 (unless (listp (second spec
))
994 (error "malformed options list: ~S" (second spec
)))
995 (unless (evenp (length (second spec
)))
996 (error "odd number of arguments in keyword options: ~S" spec
))
997 (unless (consp (cddr spec
))
998 (warn "temporary spec allocates no temps:~% ~S" spec
))
999 (dolist (name (cddr spec
))
1000 (unless (symbolp name
)
1001 (error "bad temporary name: ~S" name
))
1002 (incf *parse-vop-operand-count
*)
1003 (let ((res (make-operand-parse :name name
1005 :born
(parse-time-spec :load
)
1006 :dies
(parse-time-spec :save
))))
1007 (do ((opt (second spec
) (cddr opt
)))
1011 (setf (operand-parse-target res
)
1012 (vop-spec-arg opt
'symbol
1 nil
)))
1014 (setf (operand-parse-sc res
)
1015 (vop-spec-arg opt
'symbol
1 nil
)))
1017 (let ((offset (eval (second opt
))))
1018 (aver (typep offset
'unsigned-byte
))
1019 (setf (operand-parse-offset res
) offset
)))
1021 (setf (operand-parse-born res
) (parse-time-spec (second opt
))))
1023 (setf (operand-parse-dies res
) (parse-time-spec (second opt
))))
1024 ;; backward compatibility...
1026 (let ((scs (vop-spec-arg opt
'list
1 nil
)))
1027 (unless (= (length scs
) 1)
1028 (error "must specify exactly one SC for a temporary"))
1029 (setf (operand-parse-sc res
) (first scs
))))
1032 (error "unknown temporary option: ~S" opt
))))
1034 (unless (and (time-spec-order (operand-parse-dies res
)
1035 (operand-parse-born res
))
1036 (not (time-spec-order (operand-parse-born res
)
1037 (operand-parse-dies res
))))
1038 (error "Temporary lifetime doesn't begin before it ends: ~S" spec
))
1040 (unless (operand-parse-sc res
)
1041 (error "must specify :SC for all temporaries: ~S" spec
))
1043 (setf (vop-parse-temps parse
)
1045 (remove name
(vop-parse-temps parse
)
1046 :key
#'operand-parse-name
))))))
1049 (defun compute-parse-vop-operand-count (parse)
1050 (declare (type vop-parse parse
))
1051 (labels ((compute-count-aux (parse)
1052 (declare (type vop-parse parse
))
1053 (if (null (vop-parse-inherits parse
))
1054 (length (vop-parse-operands parse
))
1055 (+ (length (vop-parse-operands parse
))
1057 (vop-parse-or-lose (vop-parse-inherits parse
)))))))
1058 (if (null (vop-parse-inherits parse
))
1060 (compute-count-aux (vop-parse-or-lose (vop-parse-inherits parse
))))))
1062 ;;; the top level parse function: clobber PARSE to represent the
1063 ;;; specified options.
1064 (defun parse-define-vop (parse specs
)
1065 (declare (type vop-parse parse
) (list specs
))
1066 (let ((*parse-vop-operand-count
* (compute-parse-vop-operand-count parse
)))
1067 (dolist (spec specs
)
1068 (unless (consp spec
)
1069 (error "malformed option specification: ~S" spec
))
1072 (multiple-value-bind (fixed more
)
1073 (!parse-vop-operands parse
(rest spec
) :argument
)
1074 (setf (vop-parse-args parse
) fixed
)
1075 (setf (vop-parse-more-args parse
) more
)))
1077 (multiple-value-bind (fixed more
)
1078 (!parse-vop-operands parse
(rest spec
) :result
)
1079 (setf (vop-parse-results parse
) fixed
)
1080 (setf (vop-parse-more-results parse
) more
))
1081 (setf (vop-parse-conditional-p parse
) nil
))
1083 (setf (vop-parse-result-types parse
) ())
1084 (setf (vop-parse-results parse
) ())
1085 (setf (vop-parse-more-results parse
) nil
)
1086 (setf (vop-parse-conditional-p parse
) t
))
1088 (parse-temporary spec parse
))
1090 (setf (vop-parse-cost parse
)
1091 (vop-spec-arg spec
'unsigned-byte
1 nil
))
1092 (setf (vop-parse-body parse
) (cddr spec
)))
1094 (setf (vop-parse-effects parse
) (rest spec
)))
1096 (setf (vop-parse-affected parse
) (rest spec
)))
1098 (setf (vop-parse-info-args parse
) (rest spec
)))
1100 (setf (vop-parse-ignores parse
) (rest spec
)))
1102 (setf (vop-parse-variant parse
) (rest spec
)))
1104 (let ((vars (rest spec
)))
1105 (setf (vop-parse-variant-vars parse
) vars
)
1106 (setf (vop-parse-variant parse
)
1107 (make-list (length vars
) :initial-element nil
))))
1109 (setf (vop-parse-cost parse
) (vop-spec-arg spec
'unsigned-byte
)))
1111 (setf (vop-parse-vop-var parse
) (vop-spec-arg spec
'symbol
)))
1113 (setf (vop-parse-move-args parse
)
1114 (vop-spec-arg spec
'(member nil
:local-call
:full-call
1117 (setf (vop-parse-node-var parse
) (vop-spec-arg spec
'symbol
)))
1119 (setf (vop-parse-note parse
) (vop-spec-arg spec
'(or string null
))))
1121 (setf (vop-parse-arg-types parse
)
1122 (!parse-vop-operand-types
(rest spec
) t
)))
1124 (setf (vop-parse-result-types parse
)
1125 (!parse-vop-operand-types
(rest spec
) nil
)))
1127 (setf (vop-parse-translate parse
) (rest spec
)))
1129 (setf (vop-parse-guard parse
) (vop-spec-arg spec t
)))
1130 ;; FIXME: :LTN-POLICY would be a better name for this. It
1131 ;; would probably be good to leave it unchanged for a while,
1132 ;; though, at least until the first port to some other
1133 ;; architecture, since the renaming would be a change to the
1134 ;; interface between
1136 (setf (vop-parse-ltn-policy parse
)
1137 (vop-spec-arg spec
'ltn-policy
)))
1139 (setf (vop-parse-save-p parse
)
1141 '(member t nil
:compute-only
:force-to-stack
))))
1143 (error "unknown option specifier: ~S" (first spec
)))))
1146 ;;;; making costs and restrictions
1148 ;;; Given an operand, returns two values:
1149 ;;; 1. A SC-vector of the cost for the operand being in that SC,
1150 ;;; including both the costs for move functions and coercion VOPs.
1151 ;;; 2. A SC-vector holding the SC that we load into, for any SC
1152 ;;; that we can directly load from.
1154 ;;; In both vectors, unused entries are NIL. LOAD-P specifies the
1155 ;;; direction: if true, we are loading, if false we are saving.
1156 (defun compute-loading-costs (op load-p
)
1157 (declare (type operand-parse op
))
1158 (let ((scs (operand-parse-scs op
))
1159 (costs (make-array sc-number-limit
:initial-element nil
))
1160 (load-scs (make-array sc-number-limit
:initial-element nil
)))
1161 (dolist (sc-name scs
)
1162 (let* ((load-sc (meta-sc-or-lose sc-name
))
1163 (load-scn (sc-number load-sc
)))
1164 (setf (svref costs load-scn
) 0)
1165 (setf (svref load-scs load-scn
) t
)
1166 (dolist (op-sc (append (when load-p
1167 (sc-constant-scs load-sc
))
1168 (sc-alternate-scs load-sc
)))
1169 (let* ((op-scn (sc-number op-sc
))
1171 (aref (sc-load-costs load-sc
) op-scn
)
1172 (aref (sc-load-costs op-sc
) load-scn
))))
1174 (error "no move function defined to move ~:[from~;to~] SC ~
1175 ~S~%~:[to~;from~] alternate or constant SC ~S"
1176 load-p sc-name load-p
(sc-name op-sc
)))
1178 (let ((op-cost (svref costs op-scn
)))
1179 (when (or (not op-cost
) (< load op-cost
))
1180 (setf (svref costs op-scn
) load
)))
1182 (let ((op-load (svref load-scs op-scn
)))
1183 (unless (eq op-load t
)
1184 (pushnew load-scn
(svref load-scs op-scn
))))))
1186 (dotimes (i sc-number-limit
)
1187 (unless (svref costs i
)
1188 (let ((op-sc (svref *backend-meta-sc-numbers
* i
)))
1190 (let ((cost (if load-p
1191 (svref (sc-move-costs load-sc
) i
)
1192 (svref (sc-move-costs op-sc
) load-scn
))))
1194 (setf (svref costs i
) cost
)))))))))
1196 (values costs load-scs
)))
1198 (defparameter *no-costs
*
1199 (make-array sc-number-limit
:initial-element
0))
1201 (defparameter *no-loads
*
1202 (make-array sc-number-limit
:initial-element t
))
1204 ;;; Pick off the case of operands with no restrictions.
1205 (defun compute-loading-costs-if-any (op load-p
)
1206 (declare (type operand-parse op
))
1207 (if (operand-parse-scs op
)
1208 (compute-loading-costs op load-p
)
1209 (values *no-costs
* *no-loads
*)))
1211 (defun compute-costs-and-restrictions-list (ops load-p
)
1212 (declare (list ops
))
1216 (multiple-value-bind (costs scs
) (compute-loading-costs-if-any op load-p
)
1219 (values (costs) (scs))))
1221 (defun make-costs-and-restrictions (parse)
1222 (multiple-value-bind (arg-costs arg-scs
)
1223 (compute-costs-and-restrictions-list (vop-parse-args parse
) t
)
1224 (multiple-value-bind (result-costs result-scs
)
1225 (compute-costs-and-restrictions-list (vop-parse-results parse
) nil
)
1227 :cost
,(vop-parse-cost parse
)
1229 :arg-costs
',arg-costs
1230 :arg-load-scs
',arg-scs
1231 :result-costs
',result-costs
1232 :result-load-scs
',result-scs
1235 ',(if (vop-parse-more-args parse
)
1236 (compute-loading-costs-if-any (vop-parse-more-args parse
) t
)
1240 ',(if (vop-parse-more-results parse
)
1241 (compute-loading-costs-if-any (vop-parse-more-results parse
) nil
)
1244 ;;;; operand checking and stuff
1246 ;;; Given a list of arg/result restrictions, check for valid syntax
1247 ;;; and convert to canonical form.
1248 (defun !parse-vop-operand-types
(specs args-p
)
1249 (declare (list specs
))
1250 (labels ((parse-operand-type (spec)
1251 (cond ((eq spec
'*) spec
)
1253 (let ((alias (gethash spec
1254 *backend-primitive-type-aliases
*)))
1256 (parse-operand-type alias
)
1259 (error "bad thing to be a operand type: ~S" spec
))
1263 (collect ((results))
1265 (dolist (item (cdr spec
))
1266 (unless (symbolp item
)
1267 (error "bad PRIMITIVE-TYPE name in ~S: ~S"
1271 *backend-primitive-type-aliases
*)))
1273 (let ((alias (parse-operand-type alias
)))
1274 (unless (eq (car alias
) :or
)
1275 (error "can't include primitive-type ~
1276 alias ~S in an :OR restriction: ~S"
1278 (dolist (x (cdr alias
))
1281 (remove-duplicates (results)
1286 (error "can't :CONSTANT for a result"))
1287 (unless (= (length spec
) 2)
1288 (error "bad :CONSTANT argument type spec: ~S" spec
))
1291 (error "bad thing to be a operand type: ~S" spec
)))))))
1292 (mapcar #'parse-operand-type specs
)))
1294 ;;; Check the consistency of OP's SC restrictions with the specified
1295 ;;; primitive-type restriction. :CONSTANT operands have already been
1296 ;;; filtered out, so only :OR and * restrictions are left.
1298 ;;; We check that every representation allowed by the type can be
1299 ;;; directly loaded into some SC in the restriction, and that the type
1300 ;;; allows every SC in the restriction. With *, we require that T
1301 ;;; satisfy the first test, and omit the second.
1302 (defun check-operand-type-scs (parse op type load-p
)
1303 (declare (type vop-parse parse
) (type operand-parse op
))
1304 (let ((ptypes (if (eq type
'*) (list t
) (rest type
)))
1305 (scs (operand-parse-scs op
)))
1307 (multiple-value-bind (costs load-scs
) (compute-loading-costs op load-p
)
1308 (declare (ignore costs
))
1309 (dolist (ptype ptypes
)
1310 (unless (dolist (rep (primitive-type-scs
1311 (meta-primitive-type-or-lose ptype
))
1313 (when (svref load-scs rep
) (return t
)))
1314 (error "In the ~A ~:[result~;argument~] to VOP ~S,~@
1315 none of the SCs allowed by the operand type ~S can ~
1316 directly be loaded~@
1317 into any of the restriction's SCs:~% ~S~:[~;~@
1318 [* type operand must allow T's SCs.]~]"
1319 (operand-parse-name op
) load-p
(vop-parse-name parse
)
1321 scs
(eq type
'*)))))
1324 (unless (or (eq type
'*)
1325 (dolist (ptype ptypes nil
)
1326 (when (meta-sc-allowed-by-primitive-type
1327 (meta-sc-or-lose sc
)
1328 (meta-primitive-type-or-lose ptype
))
1330 (warn "~:[Result~;Argument~] ~A to VOP ~S~@
1331 has SC restriction ~S which is ~
1332 not allowed by the operand type:~% ~S"
1333 load-p
(operand-parse-name op
) (vop-parse-name parse
)
1338 ;;; If the operand types are specified, then check the number specified
1339 ;;; against the number of defined operands.
1340 (defun check-operand-types (parse ops more-op types load-p
)
1341 (declare (type vop-parse parse
) (list ops
)
1342 (type (or list
(member :unspecified
)) types
)
1343 (type (or operand-parse null
) more-op
))
1344 (unless (eq types
:unspecified
)
1345 (let ((num (+ (length ops
) (if more-op
1 0))))
1346 (unless (= (count-if-not (lambda (x)
1348 (eq (car x
) :constant
)))
1351 (error "expected ~W ~:[result~;argument~] type~P: ~S"
1352 num load-p types num
)))
1355 (let ((mtype (car (last types
))))
1356 (when (and (consp mtype
) (eq (first mtype
) :constant
))
1357 (error "can't use :CONSTANT on VOP more args")))))
1359 (when (vop-parse-translate parse
)
1360 (let ((types (specify-operand-types types ops more-op
)))
1362 (check-operand-type-scs parse x y load-p
))
1363 (if more-op
(butlast ops
) ops
)
1364 (remove-if (lambda (x)
1366 (eq (car x
) ':constant
)))
1367 (if more-op
(butlast types
) types
)))))
1371 ;;; Compute stuff that can only be computed after we are done parsing
1372 ;;; everying. We set the VOP-PARSE-OPERANDS, and do various error checks.
1373 (defun !grovel-vop-operands
(parse)
1374 (declare (type vop-parse parse
))
1376 (setf (vop-parse-operands parse
)
1377 (append (vop-parse-args parse
)
1378 (if (vop-parse-more-args parse
)
1379 (list (vop-parse-more-args parse
)))
1380 (vop-parse-results parse
)
1381 (if (vop-parse-more-results parse
)
1382 (list (vop-parse-more-results parse
)))
1383 (vop-parse-temps parse
)))
1385 (check-operand-types parse
1386 (vop-parse-args parse
)
1387 (vop-parse-more-args parse
)
1388 (vop-parse-arg-types parse
)
1391 (check-operand-types parse
1392 (vop-parse-results parse
)
1393 (vop-parse-more-results parse
)
1394 (vop-parse-result-types parse
)
1399 ;;;; function translation stuff
1401 ;;; Return forms to establish this VOP as a IR2 translation template
1402 ;;; for the :TRANSLATE functions specified in the VOP-PARSE. We also
1403 ;;; set the PREDICATE attribute for each translated function when the
1404 ;;; VOP is conditional, causing IR1 conversion to ensure that a call
1405 ;;; to the translated is always used in a predicate position.
1406 (defun !set-up-fun-translation
(parse n-template
)
1407 (declare (type vop-parse parse
))
1408 (mapcar (lambda (name)
1409 `(let ((info (fun-info-or-lose ',name
)))
1410 (setf (fun-info-templates info
)
1411 (adjoin-template ,n-template
(fun-info-templates info
)))
1412 ,@(when (vop-parse-conditional-p parse
)
1413 '((setf (fun-info-attributes info
)
1415 (ir1-attributes predicate
)
1416 (fun-info-attributes info
)))))))
1417 (vop-parse-translate parse
)))
1419 ;;; Return a form that can be evaluated to get the TEMPLATE operand type
1420 ;;; restriction from the given specification.
1421 (defun make-operand-type (type)
1422 (cond ((eq type
'*) ''*)
1424 ``(:or
,(primitive-type-or-lose ',type
)))
1428 ``(:or
,,@(mapcar (lambda (type)
1429 `(primitive-type-or-lose ',type
))
1432 ``(:constant
,#'(lambda (x)
1433 (typep x
',(second type
)))
1434 ,',(second type
)))))))
1436 (defun specify-operand-types (types ops more-ops
)
1437 (if (eq types
:unspecified
)
1438 (make-list (+ (length ops
) (if more-ops
1 0)) :initial-element
'*)
1441 ;;; Return a list of forms to use as &KEY args to MAKE-VOP-INFO for
1442 ;;; setting up the template argument and result types. Here we make an
1443 ;;; initial dummy TEMPLATE-TYPE, since it is awkward to compute the
1444 ;;; type until the template has been made.
1445 (defun make-vop-info-types (parse)
1446 (let* ((more-args (vop-parse-more-args parse
))
1447 (all-args (specify-operand-types (vop-parse-arg-types parse
)
1448 (vop-parse-args parse
)
1450 (args (if more-args
(butlast all-args
) all-args
))
1451 (more-arg (when more-args
(car (last all-args
))))
1452 (more-results (vop-parse-more-results parse
))
1453 (all-results (specify-operand-types (vop-parse-result-types parse
)
1454 (vop-parse-results parse
)
1456 (results (if more-results
(butlast all-results
) all-results
))
1457 (more-result (when more-results
(car (last all-results
))))
1458 (conditional (vop-parse-conditional-p parse
)))
1460 `(:type
(specifier-type '(function () nil
))
1461 :arg-types
(list ,@(mapcar #'make-operand-type args
))
1462 :more-args-type
,(when more-args
(make-operand-type more-arg
))
1463 :result-types
,(if conditional
1465 `(list ,@(mapcar #'make-operand-type results
)))
1466 :more-results-type
,(when more-results
1467 (make-operand-type more-result
)))))
1469 ;;;; setting up VOP-INFO
1471 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
1472 (defparameter *slot-inherit-alist
*
1473 '((:generator-function . vop-info-generator-function
))))
1475 ;;; This is something to help with inheriting VOP-INFO slots. We
1476 ;;; return a keyword/value pair that can be passed to the constructor.
1477 ;;; SLOT is the keyword name of the slot, Parse is a form that
1478 ;;; evaluates to the VOP-PARSE structure for the VOP inherited. If
1479 ;;; PARSE is NIL, then we do nothing. If the TEST form evaluates to
1480 ;;; true, then we return a form that selects the named slot from the
1481 ;;; VOP-INFO structure corresponding to PARSE. Otherwise, we return
1482 ;;; the FORM so that the slot is recomputed.
1483 (defmacro inherit-vop-info
(slot parse test form
)
1484 `(if (and ,parse
,test
)
1485 (list ,slot
`(,',(or (cdr (assoc slot
*slot-inherit-alist
*))
1486 (error "unknown slot ~S" slot
))
1487 (template-or-lose ',(vop-parse-name ,parse
))))
1488 (list ,slot
,form
)))
1490 ;;; Return a form that creates a VOP-INFO structure which describes VOP.
1491 (defun set-up-vop-info (iparse parse
)
1492 (declare (type vop-parse parse
) (type (or vop-parse null
) iparse
))
1493 (let ((same-operands
1495 (equal (vop-parse-operands parse
)
1496 (vop-parse-operands iparse
))
1497 (equal (vop-parse-info-args iparse
)
1498 (vop-parse-info-args parse
))))
1499 (variant (vop-parse-variant parse
)))
1501 (let ((nvars (length (vop-parse-variant-vars parse
))))
1502 (unless (= (length variant
) nvars
)
1503 (error "expected ~W variant values: ~S" nvars variant
)))
1506 :name
',(vop-parse-name parse
)
1507 ,@(make-vop-info-types parse
)
1508 :guard
,(when (vop-parse-guard parse
)
1509 `(lambda () ,(vop-parse-guard parse
)))
1510 :note
',(vop-parse-note parse
)
1511 :info-arg-count
,(length (vop-parse-info-args parse
))
1512 :ltn-policy
',(vop-parse-ltn-policy parse
)
1513 :save-p
',(vop-parse-save-p parse
)
1514 :move-args
',(vop-parse-move-args parse
)
1515 :effects
(vop-attributes ,@(vop-parse-effects parse
))
1516 :affected
(vop-attributes ,@(vop-parse-affected parse
))
1517 ,@(make-costs-and-restrictions parse
)
1518 ,@(make-emit-function-and-friends parse
)
1519 ,@(inherit-vop-info :generator-function iparse
1521 (equal (vop-parse-body parse
) (vop-parse-body iparse
)))
1522 (unless (eq (vop-parse-body parse
) :unspecified
)
1523 (make-generator-function parse
)))
1524 :variant
(list ,@variant
))))
1526 ;;; Define the symbol NAME to be a Virtual OPeration in the compiler.
1527 ;;; If specified, INHERITS is the name of a VOP that we default
1528 ;;; unspecified information from. Each SPEC is a list beginning with a
1529 ;;; keyword indicating the interpretation of the other forms in the
1532 ;;; :ARGS {(Name {Key Value}*)}*
1533 ;;; :RESULTS {(Name {Key Value}*)}*
1534 ;;; The Args and Results are specifications of the operand TNs passed
1535 ;;; to the VOP. If there is an inherited VOP, any unspecified options
1536 ;;; are defaulted from the inherited argument (or result) of the same
1537 ;;; name. The following operand options are defined:
1540 ;;; :SCs specifies good SCs for this operand. Other SCs will
1541 ;;; be penalized according to move costs. A load TN will be
1542 ;;; allocated if necessary, guaranteeing that the operand is
1543 ;;; always one of the specified SCs.
1545 ;;; :LOAD-TN Load-Name
1546 ;;; Load-Name is bound to the load TN allocated for this
1547 ;;; operand, or to NIL if no load TN was allocated.
1549 ;;; :LOAD-IF EXPRESSION
1550 ;;; Controls whether automatic operand loading is done.
1551 ;;; EXPRESSION is evaluated with the fixed operand TNs bound.
1552 ;;; If EXPRESSION is true,then loading is done and the variable
1553 ;;; is bound to the load TN in the generator body. Otherwise,
1554 ;;; loading is not done, and the variable is bound to the actual
1558 ;;; If specified, NAME is bound to the TN-REF for the first
1559 ;;; argument or result following the fixed arguments or results.
1560 ;;; A :MORE operand must appear last, and cannot be targeted or
1564 ;;; This operand is targeted to the named operand, indicating a
1565 ;;; desire to pack in the same location. Not legal for results.
1569 ;;; Specify the beginning or end of the operand's lifetime.
1570 ;;; :FROM can only be used with results, and :TO only with
1571 ;;; arguments. The default for the N'th argument/result is
1572 ;;; (:ARGUMENT N)/(:RESULT N). These options are necessary
1573 ;;; primarily when operands are read or written out of order.
1576 ;;; This is used in place of :RESULTS with conditional branch VOPs.
1577 ;;; There are no result values: the result is a transfer of control.
1578 ;;; The target label is passed as the first :INFO arg. The second
1579 ;;; :INFO arg is true if the sense of the test should be negated.
1580 ;;; A side effect is to set the PREDICATE attribute for functions
1581 ;;; in the :TRANSLATE option.
1583 ;;; :TEMPORARY ({Key Value}*) Name*
1584 ;;; Allocate a temporary TN for each Name, binding that variable to
1585 ;;; the TN within the body of the generators. In addition to :TARGET
1586 ;;; (which is is the same as for operands), the following options are
1590 ;;; :OFFSET SB-Offset
1591 ;;; Force the temporary to be allocated in the specified SC
1592 ;;; with the specified offset. Offset is evaluated at
1593 ;;; macroexpand time. If Offset is omitted, the register
1594 ;;; allocator chooses a free location in SC. If both SC and
1595 ;;; Offset are omitted, then the temporary is packed according
1596 ;;; to its primitive type.
1600 ;;; Similar to the argument/result option, this specifies the
1601 ;;; start and end of the temporaries' lives. The defaults are
1602 ;;; :LOAD and :SAVE, i.e. the duration of the VOP. The other
1603 ;;; intervening phases are :ARGUMENT, :EVAL and :RESULT.
1604 ;;; Non-zero sub-phases can be specified by a list, e.g. by
1605 ;;; default the second argument's life ends at (:ARGUMENT 1).
1607 ;;; :GENERATOR Cost Form*
1608 ;;; Specifies the translation into assembly code. Cost is the
1609 ;;; estimated cost of the code emitted by this generator. The body
1610 ;;; is arbitrary Lisp code that emits the assembly language
1611 ;;; translation of the VOP. An ASSEMBLE form is wrapped around
1612 ;;; the body, so code may be emitted by using the local INST macro.
1613 ;;; During the evaluation of the body, the names of the operands
1614 ;;; and temporaries are bound to the actual TNs.
1616 ;;; :EFFECTS Effect*
1617 ;;; :AFFECTED Effect*
1618 ;;; Specifies the side effects that this VOP has and the side
1619 ;;; effects that effect its execution. If unspecified, these
1620 ;;; default to the worst case.
1623 ;;; Define some magic arguments that are passed directly to the code
1624 ;;; generator. The corresponding trailing arguments to VOP or
1625 ;;; %PRIMITIVE are stored in the VOP structure. Within the body
1626 ;;; of the generators, the named variables are bound to these
1627 ;;; values. Except in the case of :CONDITIONAL VOPs, :INFO arguments
1628 ;;; cannot be specified for VOPS that are the direct translation
1629 ;;; for a function (specified by :TRANSLATE).
1632 ;;; Causes the named variables to be declared IGNORE in the
1636 ;;; :VARIANT-VARS Name*
1637 ;;; These options provide a way to parameterize families of VOPs
1638 ;;; that differ only trivially. :VARIANT makes the specified
1639 ;;; evaluated Things be the "variant" associated with this VOP.
1640 ;;; :VARIANT-VARS causes the named variables to be bound to the
1641 ;;; corresponding Things within the body of the generator.
1643 ;;; :VARIANT-COST Cost
1644 ;;; Specifies the cost of this VOP, overriding the cost of any
1645 ;;; inherited generator.
1647 ;;; :NOTE {String | NIL}
1648 ;;; A short noun-like phrase describing what this VOP "does", i.e.
1649 ;;; the implementation strategy. If supplied, efficiency notes will
1650 ;;; be generated when type uncertainty prevents :TRANSLATE from
1651 ;;; working. NIL inhibits any efficiency note.
1653 ;;; :ARG-TYPES {* | PType | (:OR PType*) | (:CONSTANT Type)}*
1654 ;;; :RESULT-TYPES {* | PType | (:OR PType*)}*
1655 ;;; Specify the template type restrictions used for automatic
1656 ;;; translation. If there is a :MORE operand, the last type is the
1657 ;;; more type. :CONSTANT specifies that the argument must be a
1658 ;;; compile-time constant of the specified Lisp type. The constant
1659 ;;; values of :CONSTANT arguments are passed as additional :INFO
1660 ;;; arguments rather than as :ARGS.
1662 ;;; :TRANSLATE Name*
1663 ;;; This option causes the VOP template to be entered as an IR2
1664 ;;; translation for the named functions.
1666 ;;; :POLICY {:SMALL | :FAST | :SAFE | :FAST-SAFE}
1667 ;;; Specifies the policy under which this VOP is the best translation.
1670 ;;; Specifies a Form that is evaluated in the global environment.
1671 ;;; If form returns NIL, then emission of this VOP is prohibited
1672 ;;; even when all other restrictions are met.
1676 ;;; In the generator, bind the specified variable to the VOP or
1677 ;;; the Node that generated this VOP.
1679 ;;; :SAVE-P {NIL | T | :COMPUTE-ONLY | :FORCE-TO-STACK}
1680 ;;; Indicates how a VOP wants live registers saved.
1682 ;;; :MOVE-ARGS {NIL | :FULL-CALL | :LOCAL-CALL | :KNOWN-RETURN}
1683 ;;; Indicates if and how the more args should be moved into a
1684 ;;; different frame.
1685 (def!macro define-vop
((name &optional inherits
) &body specs
)
1686 (declare (type symbol name
))
1687 ;; Parse the syntax into a VOP-PARSE structure, and then expand into
1688 ;; code that creates the appropriate VOP-INFO structure at load time.
1689 ;; We implement inheritance by copying the VOP-PARSE structure for
1690 ;; the inherited structure.
1691 (let* ((inherited-parse (when inherits
1692 (vop-parse-or-lose inherits
)))
1694 (copy-vop-parse inherited-parse
)
1697 (setf (vop-parse-name parse
) name
)
1698 (setf (vop-parse-inherits parse
) inherits
)
1700 (parse-define-vop parse specs
)
1701 (!grovel-vop-operands parse
)
1704 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
1705 (setf (gethash ',name
*backend-parsed-vops
*)
1708 (let ((,n-res
,(set-up-vop-info inherited-parse parse
)))
1709 (setf (gethash ',name
*backend-template-names
*) ,n-res
)
1710 (setf (template-type ,n-res
)
1711 (specifier-type (template-type-specifier ,n-res
)))
1712 ,@(!set-up-fun-translation parse n-res
))
1715 ;;;; emission macros
1717 ;;; Return code to make a list of VOP arguments or results, linked by
1718 ;;; TN-REF-ACROSS. The first value is code, the second value is LET*
1719 ;;; forms, and the third value is a variable that evaluates to the
1720 ;;; head of the list, or NIL if there are no operands. Fixed is a list
1721 ;;; of forms that evaluate to TNs for the fixed operands. TN-REFS will
1722 ;;; be made for these operands according using the specified value of
1723 ;;; WRITE-P. More is an expression that evaluates to a list of TN-REFS
1724 ;;; that will be made the tail of the list. If it is constant NIL,
1725 ;;; then we don't bother to set the tail.
1726 (defun make-operand-list (fixed more write-p
)
1732 (let ((n-ref (gensym)))
1733 (binds `(,n-ref
(reference-tn ,op
,write-p
)))
1735 (forms `(setf (tn-ref-across ,n-prev
) ,n-ref
))
1736 (setq n-head n-ref
))
1737 (setq n-prev n-ref
)))
1740 (let ((n-more (gensym)))
1741 (binds `(,n-more
,more
))
1743 (forms `(setf (tn-ref-across ,n-prev
) ,n-more
))
1744 (setq n-head n-more
))))
1746 (values (forms) (binds) n-head
))))
1748 ;;; Emit-Template Node Block Template Args Results [Info]
1750 ;;; Call the emit function for TEMPLATE, linking the result in at the
1752 (defmacro emit-template
(node block template args results
&optional info
)
1753 (let ((n-first (gensym))
1755 (once-only ((n-node node
)
1757 (n-template template
))
1758 `(multiple-value-bind (,n-first
,n-last
)
1759 (funcall (template-emit-function ,n-template
)
1760 ,n-node
,n-block
,n-template
,args
,results
1761 ,@(when info
`(,info
)))
1762 (insert-vop-sequence ,n-first
,n-last
,n-block nil
)))))
1764 ;;; VOP Name Node Block Arg* Info* Result*
1766 ;;; Emit the VOP (or other template) NAME at the end of the IR2-BLOCK
1767 ;;; BLOCK, using NODE for the source context. The interpretation of
1768 ;;; the remaining arguments depends on the number of operands of
1769 ;;; various kinds that are declared in the template definition. VOP
1770 ;;; cannot be used for templates that have more-args or more-results,
1771 ;;; since the number of arguments and results is indeterminate for
1772 ;;; these templates. Use VOP* instead.
1774 ;;; ARGS and RESULTS are the TNs that are to be referenced by the
1775 ;;; template as arguments and results. If the template has
1776 ;;; codegen-info arguments, then the appropriate number of INFO forms
1777 ;;; following the arguments are used for codegen info.
1778 (defmacro vop
(name node block
&rest operands
)
1779 (let* ((parse (vop-parse-or-lose name
))
1780 (arg-count (length (vop-parse-args parse
)))
1781 (result-count (length (vop-parse-results parse
)))
1782 (info-count (length (vop-parse-info-args parse
)))
1783 (noperands (+ arg-count result-count info-count
))
1786 (n-template (gensym)))
1788 (when (or (vop-parse-more-args parse
) (vop-parse-more-results parse
))
1789 (error "cannot use VOP with variable operand count templates"))
1790 (unless (= noperands
(length operands
))
1791 (error "called with ~W operands, but was expecting ~W"
1792 (length operands
) noperands
))
1794 (multiple-value-bind (acode abinds n-args
)
1795 (make-operand-list (subseq operands
0 arg-count
) nil nil
)
1796 (multiple-value-bind (rcode rbinds n-results
)
1797 (make-operand-list (subseq operands
(+ arg-count info-count
)) nil t
)
1801 (dolist (info (subseq operands arg-count
(+ arg-count info-count
)))
1802 (let ((temp (gensym)))
1803 (ibinds `(,temp
,info
))
1806 `(let* ((,n-node
,node
)
1808 (,n-template
(template-or-lose ',name
))
1814 (emit-template ,n-node
,n-block
,n-template
,n-args
1817 `((list ,@(ivars)))))
1820 ;;; VOP* Name Node Block (Arg* More-Args) (Result* More-Results) Info*
1822 ;;; This is like VOP, but allows for emission of templates with
1823 ;;; arbitrary numbers of arguments, and for emission of templates
1824 ;;; using already-created TN-REF lists.
1826 ;;; The ARGS and RESULTS are TNs to be referenced as the first
1827 ;;; arguments and results to the template. More-Args and More-Results
1828 ;;; are heads of TN-REF lists that are added onto the end of the
1829 ;;; TN-REFS for the explicitly supplied operand TNs. The TN-REFS for
1830 ;;; the more operands must have the TN and WRITE-P slots correctly
1833 ;;; As with VOP, the INFO forms are evaluated and passed as codegen
1835 (defmacro vop
* (name node block args results
&rest info
)
1836 (declare (type cons args results
))
1837 (let* ((parse (vop-parse-or-lose name
))
1838 (arg-count (length (vop-parse-args parse
)))
1839 (result-count (length (vop-parse-results parse
)))
1840 (info-count (length (vop-parse-info-args parse
)))
1841 (fixed-args (butlast args
))
1842 (fixed-results (butlast results
))
1845 (n-template (gensym)))
1847 (unless (or (vop-parse-more-args parse
)
1848 (<= (length fixed-args
) arg-count
))
1849 (error "too many fixed arguments"))
1850 (unless (or (vop-parse-more-results parse
)
1851 (<= (length fixed-results
) result-count
))
1852 (error "too many fixed results"))
1853 (unless (= (length info
) info-count
)
1854 (error "expected ~W info args" info-count
))
1856 (multiple-value-bind (acode abinds n-args
)
1857 (make-operand-list fixed-args
(car (last args
)) nil
)
1858 (multiple-value-bind (rcode rbinds n-results
)
1859 (make-operand-list fixed-results
(car (last results
)) t
)
1861 `(let* ((,n-node
,node
)
1863 (,n-template
(template-or-lose ',name
))
1868 (emit-template ,n-node
,n-block
,n-template
,n-args
,n-results
1873 ;;;; miscellaneous macros
1875 ;;; SC-Case TN {({(SC-Name*) | SC-Name | T} Form*)}*
1877 ;;; Case off of TN's SC. The first clause containing TN's SC is
1878 ;;; evaluated, returning the values of the last form. A clause
1879 ;;; beginning with T specifies a default. If it appears, it must be
1880 ;;; last. If no default is specified, and no clause matches, then an
1881 ;;; error is signalled.
1882 (def!macro sc-case
(tn &body forms
)
1883 (let ((n-sc (gensym))
1885 (collect ((clauses))
1886 (do ((cases forms
(rest cases
)))
1888 (clauses `(t (error "unknown SC to SC-CASE for ~S:~% ~S" ,n-tn
1889 (sc-name (tn-sc ,n-tn
))))))
1890 (let ((case (first cases
)))
1892 (error "illegal SC-CASE clause: ~S" case
))
1893 (let ((head (first case
)))
1896 (error "T case is not last in SC-CASE."))
1897 (clauses `(t nil
,@(rest case
)))
1899 (clauses `((or ,@(mapcar (lambda (x)
1900 `(eql ,(meta-sc-number-or-lose x
)
1902 (if (atom head
) (list head
) head
)))
1903 nil
,@(rest case
))))))
1906 (,n-sc
(sc-number (tn-sc ,n-tn
))))
1907 (cond ,@(clauses))))))
1909 ;;; Return true if TNs SC is any of the named SCs, false otherwise.
1910 (defmacro sc-is
(tn &rest scs
)
1911 (once-only ((n-sc `(sc-number (tn-sc ,tn
))))
1912 `(or ,@(mapcar (lambda (x)
1913 `(eql ,n-sc
,(meta-sc-number-or-lose x
)))
1916 ;;; Iterate over the IR2 blocks in component, in emission order.
1917 (defmacro do-ir2-blocks
((block-var component
&optional result
)
1919 `(do ((,block-var
(block-info (component-head ,component
))
1920 (ir2-block-next ,block-var
)))
1921 ((null ,block-var
) ,result
)
1924 ;;; Iterate over all the TNs live at some point, with the live set
1925 ;;; represented by a local conflicts bit-vector and the IR2-BLOCK
1926 ;;; containing the location.
1927 (defmacro do-live-tns
((tn-var live block
&optional result
) &body body
)
1928 (let ((n-conf (gensym))
1932 (once-only ((n-live live
)
1935 (flet ((,n-bod
(,tn-var
) ,@body
))
1936 ;; Do component-live TNs.
1937 (dolist (,tn-var
(ir2-component-component-tns
1940 (ir2-block-block ,n-block
)))))
1943 (let ((,ltns
(ir2-block-local-tns ,n-block
)))
1944 ;; Do TNs always-live in this block and live :MORE TNs.
1945 (do ((,n-conf
(ir2-block-global-tns ,n-block
)
1946 (global-conflicts-next-blockwise ,n-conf
)))
1948 (when (or (eq (global-conflicts-kind ,n-conf
) :live
)
1949 (let ((,i
(global-conflicts-number ,n-conf
)))
1950 (and (eq (svref ,ltns
,i
) :more
)
1951 (not (zerop (sbit ,n-live
,i
))))))
1952 (,n-bod
(global-conflicts-tn ,n-conf
))))
1953 ;; Do TNs locally live in the designated live set.
1954 (dotimes (,i
(ir2-block-local-tn-count ,n-block
) ,result
)
1955 (unless (zerop (sbit ,n-live
,i
))
1956 (let ((,tn-var
(svref ,ltns
,i
)))
1957 (when (and ,tn-var
(not (eq ,tn-var
:more
)))
1958 (,n-bod
,tn-var
)))))))))))
1960 ;;; Iterate over all the IR2 blocks in PHYSENV, in emit order.
1961 (defmacro do-physenv-ir2-blocks
((block-var physenv
&optional result
)
1963 (once-only ((n-physenv physenv
))
1964 (once-only ((n-first `(lambda-block (physenv-lambda ,n-physenv
))))
1965 (once-only ((n-tail `(block-info
1967 (block-component ,n-first
)))))
1968 `(do ((,block-var
(block-info ,n-first
)
1969 (ir2-block-next ,block-var
)))
1970 ((or (eq ,block-var
,n-tail
)
1971 (not (eq (ir2-block-physenv ,block-var
) ,n-physenv
)))