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-bases
(&rest definitions
&aux
(index -
1) forms
)
31 (dolist (def definitions
)
32 (destructuring-bind (name kind
&key size
(size-increment size
)
36 (declare (type symbol name
))
37 (declare (type (member :finite
:unbounded
:non-packed
) kind
))
39 ;; SIZE is either mandatory or forbidden.
43 (error "A size specification is meaningless in a ~S SB." kind
)))
45 (unless size
(error "Size is not specified in a ~S SB." kind
))
46 (aver (<= size sb-vm
:finite-sc-offset-limit
))
47 (aver (= 1 (logcount size-alignment
)))
48 (aver (not (logtest size
(1- size-alignment
))))
49 (aver (not (logtest size-increment
(1- size-alignment
))))))
51 (push (if (eq kind
:non-packed
)
52 `(make-storage-base :name
',name
:kind
,kind
)
53 `(make-finite-sb-template
54 :index
,(incf index
) :name
',name
55 :kind
,kind
:size
,size
56 :size-increment
,size-increment
57 :size-alignment
,size-alignment
))
59 ;; Do not clobber the global var while running the cross-compiler.
60 `(eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
61 (setf *backend-sbs
* (vector ,@(nreverse forms
)))))
63 ;;; Define a storage class NAME that uses the named Storage-Base.
64 ;;; NUMBER is a small, non-negative integer that is used as an alias.
65 ;;; The following keywords are defined:
67 ;;; :ELEMENT-SIZE Size
68 ;;; The size of objects in this SC in whatever units the SB uses.
69 ;;; This defaults to 1.
72 ;;; The alignment restrictions for this SC. TNs will only be
73 ;;; allocated at offsets that are an even multiple of this number.
74 ;;; This defaults to 1.
76 ;;; :LOCATIONS (Location*)
77 ;;; If the SB is :FINITE, then this is a list of the offsets within
78 ;;; the SB that are in this SC.
80 ;;; :RESERVE-LOCATIONS (Location*)
81 ;;; A subset of the Locations that the register allocator should try to
82 ;;; reserve for operand loading (instead of to hold variable values.)
85 ;;; If T, then values stored in this SC must be saved in one of the
86 ;;; non-save-p :ALTERNATE-SCs across calls.
88 ;;; :ALTERNATE-SCS (SC*)
89 ;;; Indicates other SCs that can be used to hold values from this SC across
90 ;;; calls or when storage in this SC is exhausted. The SCs should be
91 ;;; specified in order of decreasing \"goodness\". There must be at least
92 ;;; one SC in an unbounded SB, unless this SC is only used for restricted or
95 ;;; :CONSTANT-SCS (SC*)
96 ;;; A list of the names of all the constant SCs that can be loaded into this
97 ;;; SC by a move function.
98 (defmacro !define-storage-class
(name number sb-name
&key
(element-size '1)
99 (alignment '1) locations reserve-locations
100 save-p alternate-scs constant-scs
102 (declare (type symbol name
))
103 (declare (type sc-number number
))
104 (declare (type symbol sb-name
))
105 (declare (type list locations reserve-locations alternate-scs constant-scs
))
106 (declare (type boolean save-p
))
107 (unless (= (logcount alignment
) 1)
108 (error "alignment not a power of two: ~W" alignment
))
110 (let ((sb (sb-or-lose sb-name
)))
111 (if (eq (sb-kind sb
) :finite
)
112 (let ((size (sb-size sb
))
113 (element-size (eval element-size
)))
114 (declare (type unsigned-byte element-size
))
115 (dolist (el locations
)
116 (declare (type unsigned-byte el
))
117 (unless (<= 1 (+ el element-size
) size
)
118 (error "SC element ~W out of bounds for ~S" el sb
))))
120 (error ":LOCATIONS is meaningless in a ~S SB." (sb-kind sb
))))
122 (unless (subsetp reserve-locations locations
)
123 (error "RESERVE-LOCATIONS not a subset of LOCATIONS."))
125 (when (and (or alternate-scs constant-scs
)
126 (eq (sb-kind sb
) :non-packed
))
128 "It's meaningless to specify alternate or constant SCs in a ~S SB."
132 (if (or (eq sb-name
'non-descriptor-stack
)
133 (find 'non-descriptor-stack
134 (mapcar #'sc-or-lose alternate-scs
)
136 (sb-name (sc-sb x
)))))
139 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
140 (let ((res (make-storage-class
141 :name
',name
:number
',number
142 :sb
(sb-or-lose ',sb-name
)
143 :element-size
,element-size
144 :operand-size
,operand-size
145 :alignment
,alignment
146 :locations
(make-sc-locations ',locations
)
147 :reserve-locations
(make-sc-locations ',reserve-locations
)
149 :number-stack-p
,nstack-p
150 :alternate-scs
(mapcar #'sc-or-lose
152 :constant-scs
(mapcar #'sc-or-lose
154 (setf (gethash ',name
*backend-sc-names
*) res
)
155 (setf (svref (sc-load-costs res
) ',number
) 0)))
157 (let ((old (svref *backend-sc-numbers
* ',number
)))
158 (when (and old
(not (eq (sc-name old
) ',name
)))
159 (warn "redefining SC number ~W from ~S to ~S" ',number
160 (sc-name old
) ',name
)))
162 (setf (svref *backend-sc-numbers
* ',number
) (sc-or-lose ',name
))
163 (setf (gethash ',name
*backend-sc-names
*) (sc-or-lose ',name
))
164 (setf (sc-sb (sc-or-lose ',name
)) (sb-or-lose ',sb-name
))
167 ;;;; move/coerce definition
169 ;;; Given a list of pairs of lists of SCs (as given to DEFINE-MOVE-VOP,
170 ;;; etc.), bind TO-SC and FROM-SC to all the combinations.
171 (defmacro do-sc-pairs
((from-sc-var to-sc-var scs
) &body body
)
172 `(do ((froms ,scs
(cddr froms
))
173 (tos (cdr ,scs
) (cddr tos
)))
175 (dolist (from (car froms
))
176 (let ((,from-sc-var
(sc-or-lose from
)))
177 (dolist (to (car tos
))
178 (let ((,to-sc-var
(sc-or-lose to
)))
181 ;;; Define the function NAME and note it as the function used for
182 ;;; moving operands from the From-SCs to the To-SCs. Cost is the cost
183 ;;; of this move operation. The function is called with three
184 ;;; arguments: the VOP (for context), and the source and destination
185 ;;; TNs. An ASSEMBLE form is wrapped around the body. All uses of
186 ;;; DEFINE-MOVE-FUN should be compiled before any uses of
188 (defmacro define-move-fun
((name cost
) lambda-list scs
&body body
)
189 (declare (type index cost
))
190 (when (or (oddp (length scs
)) (null scs
))
191 (error "malformed SCs spec: ~S" scs
))
193 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
194 (do-sc-pairs (from-sc to-sc
',scs
)
195 (unless (eq from-sc to-sc
)
196 (let ((num (sc-number from-sc
)))
197 (setf (svref (sc-move-funs to-sc
) num
) ',name
)
198 (setf (svref (sc-load-costs to-sc
) num
) ',cost
)))))
200 (defun ,name
,lambda-list
201 (declare (ignorable ,(car lambda-list
)))
202 (sb-assem:assemble
()
205 (defglobal *sc-vop-slots
*
206 '((:move . sc-move-vops
)
207 (:move-arg . sc-move-arg-vops
)))
209 ;;;; primitive type definition
211 ;;; Define a primitive type NAME. Each SCS entry specifies a storage
212 ;;; class that values of this type may be allocated in. TYPE is the
213 ;;; type descriptor for the Lisp type that is equivalent to this type.
214 (defmacro !def-primitive-type
(name scs
&key
(type name
))
215 (declare (type symbol name
) (type list scs
))
216 (let ((scns (mapcar #'sc-number-or-lose scs
)))
218 (/show
"doing !DEF-PRIMITIVE-TYPE" ,(string name
))
219 (assert (not (gethash ',name
*backend-primitive-type-names
*)))
220 (setf (gethash ',name
*backend-primitive-type-names
*)
221 (make-primitive-type :name
',name
224 (/show0
"done with !DEF-PRIMITIVE-TYPE")
227 ;;; Define NAME to be an alias for RESULT in VOP operand type restrictions.
228 (defmacro !def-primitive-type-alias
(name result
)
229 ;; Just record the translation.
231 (assert (not (assoc ',name
*backend-primitive-type-aliases
*)))
232 (push (cons ',name
,result
) *backend-primitive-type-aliases
*)
236 ;;;; VOP definition structures
238 ;;;; DEFINE-VOP uses some fairly complex data structures at
239 ;;;; meta-compile time, both to hold the results of parsing the
240 ;;;; elaborate syntax and to retain the information so that it can be
241 ;;;; inherited by other VOPs.
243 ;;; FIXME: all VOP-PARSE slots should be readonly.
244 ;;; Unfortunately it acts as both mutable working storage for the DEFINE-VOP
245 ;;; expander, and the immutable object finally produced.
247 ;;; An OPERAND-PARSE object contains stuff we need to know about an
248 ;;; operand or temporary at meta-compile time. Besides the obvious
249 ;;; stuff, we also store the names of per-operand temporaries here.
250 (defstruct (operand-parse
252 #-sb-xc-host
(:pure t
))
253 ;; name of the operand (which we bind to the TN)
254 (name nil
:type symbol
:read-only t
)
255 ;; the way this operand is used:
256 (kind (missing-arg) :read-only t
257 :type
(member :argument
:result
:temporary
258 :more-argument
:more-result
))
259 ;; If true, the name of an operand that this operand is targeted to.
260 ;; This is only meaningful in :ARGUMENT and :TEMPORARY operands.
261 (target nil
:type
(or symbol null
) :read-only t
)
262 ;; TEMP is a temporary that holds the TN-REF for this operand.
263 (temp (make-operand-parse-temp) :type symbol
)
264 ;; the time that this operand is first live and the time at which it
265 ;; becomes dead again. These are TIME-SPECs, as returned by
267 (born nil
:read-only t
)
268 (dies nil
:read-only t
)
269 ;; Variable that is bound to the load TN allocated for this operand, or to
270 ;; NIL if no load-TN was allocated.
271 (load-tn (make-operand-parse-load-tn) :type symbol
:read-only t
)
272 ;; an expression that tests whether to do automatic operand loading
273 (load t
:read-only t
)
274 ;; In a wired or restricted temporary this is the SC the TN is to be
275 ;; packed in. Otherwise, if a non-nil list, the names of the SCs that
276 ;; this operand is allowed into. If NIL, there is no restriction.
277 (scs nil
:type
(or symbol list
) :read-only t
)
278 ;; If non-null, we are a temp wired to this offset in SC.
279 (offset nil
:type
(or unsigned-byte null
) :read-only t
)
281 (declaim (freeze-type operand-parse
))
283 (defun operand-parse-sc (parse) ; Enforce a single symbol
284 (the (and symbol
(not null
)) (operand-parse-scs parse
)))
286 ;;; A VOP-PARSE object holds everything we need to know about a VOP at
287 ;;; meta-compile time.
288 (defstruct (vop-parse #-sb-xc-host
(:pure t
))
290 ;; the name of this VOP
291 (name nil
:type symbol
)
292 ;; If true, then the name of the VOP we inherit from.
293 (inherits nil
:type
(or symbol null
))
294 ;; lists of OPERAND-PARSE structures describing the arguments,
295 ;; results and temporaries of the VOP
296 (args nil
:type list
)
297 (results nil
:type list
)
298 (temps nil
:type list
)
299 ;; OPERAND-PARSE structures containing information about more args
300 ;; and results. If null, then there there are no more operands of
302 (more-args nil
:type
(or operand-parse null
))
303 (more-results nil
:type
(or operand-parse null
))
304 ;; a list of all the above together
305 (operands nil
:type list
)
306 ;; Which results can accept :unused TNs
307 (optional-results nil
:type list
)
308 ;; names of variables that should be declared IGNORE
309 (ignores () :type list
)
310 ;; true if this is a :CONDITIONAL VOP. T if a branchful VOP,
311 ;; a list of condition descriptor otherwise. See $ARCH/pred.lisp
312 ;; for more information.
314 ;; argument and result primitive types. These are pulled out of the
315 ;; operands, since we often want to change them without respecifying
317 (arg-types :unspecified
:type
(or (member :unspecified
) list
))
318 (result-types :unspecified
:type
(or (member :unspecified
) list
))
319 ;; the guard expression specified, or NIL if none
321 ;; the cost of and body code for the generator
322 (cost 0 :type unsigned-byte
)
323 (body :unspecified
:type
(or (member :unspecified
) list
))
324 ;; info for VOP variants. The list of forms to be evaluated to get
325 ;; the variant args for this VOP, and the list of variables to be
326 ;; bound to the variant args.
327 (variant () :type list
)
328 (variant-vars () :type list
)
329 ;; variables bound to the VOP and Vop-Node when in the generator body
330 (vop-var '.vop.
:type symbol
)
331 (node-var nil
:type
(or symbol null
))
332 ;; a list of the names of the codegen-info arguments to this VOP
333 (info-args () :type list
)
334 ;; an efficiency note associated with this VOP
335 (note nil
:type
(or string null
))
336 ;; a list of the names of functions this VOP is a translation of and
337 ;; the policy that allows this translation to be done. :FAST is a
338 ;; safe default, since it isn't a safe policy.
339 (translate () :type list
)
340 (ltn-policy :fast
:type ltn-policy
)
341 ;; stuff used by life analysis
342 (save-p nil
:type
(member t nil
:compute-only
:force-to-stack
))
343 ;; info about how to emit MOVE-ARG VOPs for the &MORE operand in
345 (move-args nil
:type
(member nil
:local-call
:full-call
:known-return
:fixed
))
346 (before-load :unspecified
:type
(or (member :unspecified
) list
))
348 (declaim (freeze-type vop-parse
))
349 (defprinter (vop-parse)
351 (inherits :test inherits
)
355 (more-args :test more-args
)
356 (more-results :test more-results
)
357 (conditional-p :test conditional-p
)
363 (variant :test variant
)
364 (variant-vars :test variant-vars
)
365 (info-args :test info-args
)
369 (save-p :test save-p
)
370 (move-args :test move-args
))
372 ;;; The list of slots in the structure, not including the OPERANDS slot.
373 ;;; Order here is insignificant; it happens to be alphabetical.
374 (defglobal vop-parse-slot-names
375 '(arg-types args before-load body conditional-p cost gc-barrier guard ignores info-args inherits
376 ltn-policy more-args more-results move-args name node-var note optional-results result-types
377 results save-p source-location temps translate variant variant-vars vop-var
))
378 ;; A sanity-check. Of course if this fails, the likelihood is that you can't even
379 ;; get this far in cross-compilaion. So it's probably not worth much.
380 (eval-when (#+sb-xc
:compile-toplevel
)
381 (assert (equal (length (dd-slots (find-defstruct-description 'vop-parse
)))
382 (1+ (length vop-parse-slot-names
)))))
384 (defprinter (operand-parse)
387 (target :test target
)
392 (offset :test offset
))
394 ;;; Make NAME be the VOP used to move values in the specified FROM-SCs
395 ;;; to the representation of the TO-SCs of each SC pair in SCS.
397 ;;; If KIND is :MOVE-ARG, then the VOP takes an extra argument,
398 ;;; which is the frame pointer of the frame to move into.
400 ;;; We record the VOP and costs for all SCs that we can move between
401 ;;; (including implicit loading).
402 (defmacro define-move-vop
(name kind
&rest scs
)
403 (when (or (oddp (length scs
)) (null scs
))
404 (error "malformed SCs spec: ~S" scs
))
405 (let ((accessor (or (cdr (assoc kind
*sc-vop-slots
*))
406 (error "unknown kind ~S" kind
))))
408 ,@(when (eq kind
:move
)
409 `((eval-when (:compile-toplevel
:load-toplevel
:execute
)
410 (do-sc-pairs (from-sc to-sc
',scs
)
411 (compute-move-costs from-sc to-sc
413 (vop-parse-or-lose name
)))))))
415 (let ((vop (template-or-lose ',name
)))
416 (setf (vop-info-move-vop-p vop
) t
)
417 (do-sc-pairs (from-sc to-sc
',scs
)
418 (dolist (dest-sc (cons to-sc
(sc-alternate-scs to-sc
)))
419 (let ((vec (,accessor dest-sc
)))
420 (let ((scn (sc-number from-sc
)))
421 (setf (svref vec scn
)
422 (adjoin-template vop
(svref vec scn
))))
423 (dolist (sc (append (sc-alternate-scs from-sc
)
424 (sc-constant-scs from-sc
)))
425 (let ((scn (sc-number sc
)))
426 (setf (svref vec scn
)
427 (adjoin-template vop
(svref vec scn
))))))))))))
429 ;;;; miscellaneous utilities
431 ;;; Find the operand or temporary with the specifed Name in the VOP
432 ;;; Parse. If there is no such operand, signal an error. Also error if
433 ;;; the operand kind isn't one of the specified Kinds. If Error-P is
434 ;;; NIL, just return NIL if there is no such operand.
435 (defun find-operand (name parse
&optional
436 (kinds '(:argument
:result
:temporary
))
438 (declare (symbol name
) (type vop-parse parse
) (list kinds
))
439 (let ((found (find name
(vop-parse-operands parse
)
440 :key
#'operand-parse-name
)))
442 (unless (member (operand-parse-kind found
) kinds
)
443 (error "Operand ~S isn't one of these kinds: ~S." name kinds
))
445 (error "~S is not an operand to ~S." name
(vop-parse-name parse
))))
448 ;;; Get the VOP-PARSE structure for NAME or die trying. For all
449 ;;; meta-compile time uses, the VOP-PARSE should be used instead of
451 (defun vop-parse-or-lose (name)
453 (or (gethash name
*backend-parsed-vops
*)
454 (error "~S is not the name of a defined VOP." name
))))
456 ;;; Return a list of LET-forms to parse a TN-REF list into the temps
457 ;;; specified by the operand-parse structures. MORE-OPERAND is the
458 ;;; OPERAND-PARSE describing any more operand, or NIL if none. REFS is
459 ;;; an expression that evaluates into the first TN-REF.
460 (defun access-operands (operands more-operand refs
)
461 (declare (list operands
))
464 (dolist (op operands
)
465 (let ((n-ref (operand-parse-temp op
)))
466 (res `(,n-ref
,prev
))
467 (setq prev
`(tn-ref-across ,n-ref
))))
470 (res `(,(operand-parse-name more-operand
) ,prev
))))
473 ;;; This is used with ACCESS-OPERANDS to prevent warnings for TN-REF
474 ;;; temps not used by some particular function. It returns the name of
475 ;;; the last operand, or NIL if OPERANDS is NIL.
476 (defun ignore-unreferenced-temps (operands)
478 (operand-parse-temp (car (last operands
)))))
480 ;;; Grab an arg out of a VOP spec, checking the type and syntax and stuff.
481 (defun vop-spec-arg (spec type
&optional
(n 1) (last t
))
482 (let ((len (length spec
)))
484 (error "~:R argument missing: ~S" n spec
))
485 (when (and last
(> len
(1+ n
)))
486 (error "extra junk at end of ~S" spec
))
487 (let ((thing (elt spec n
)))
488 (unless (typep thing type
)
489 (error "~:R argument is not a ~S: ~S" n type spec
))
494 ;;; Return a time spec describing a time during the evaluation of a
495 ;;; VOP, used to delimit operand and temporary lifetimes. The
496 ;;; representation is a fixnum [phase][16-bit sub-phase].
497 ;;; The sub-phase is 0 in the :LOAD and :SAVE phases.
498 (defun parse-time-spec (spec)
499 (let ((dspec (if (atom spec
) (list spec
0) spec
)))
500 (unless (and (= (length dspec
) 2)
501 (typep (second dspec
) 'unsigned-byte
))
502 (error "malformed time specifier: ~S" spec
))
503 (let ((phase (case (first dspec
)
510 (error "unknown phase in time specifier: ~S" spec
))) )
511 (sub-phase (second dspec
)))
515 ;;;; generation of emit functions
517 (defun compute-temporaries-description (parse)
518 (let ((temps (vop-parse-temps parse
))
519 (element-type '(unsigned-byte 16)))
521 (let ((results (sb-xc:make-array
(length temps
) :element-type element-type
))
524 (declare (type operand-parse temp
))
525 (let ((sc (operand-parse-sc temp
))
526 (offset (operand-parse-offset temp
)))
528 (setf (aref results index
)
530 (+ (ash offset
(1+ sb-vm
:sc-number-bits
))
531 (ash (sc-number-or-lose sc
) 1)
533 (ash (sc-number-or-lose sc
) 1))))
537 (defun compute-ref-ordering (parse)
538 (let* ((num-args (+ (length (vop-parse-args parse
))
539 (if (vop-parse-more-args parse
) 1 0)))
540 (num-results (+ (length (vop-parse-results parse
))
541 (if (vop-parse-more-results parse
) 1 0)))
543 (collect ((refs) (targets))
544 (dolist (op (vop-parse-operands parse
))
545 (when (operand-parse-target op
)
546 (unless (member (operand-parse-kind op
) '(:argument
:temporary
))
547 (error "cannot target a ~S operand: ~S" (operand-parse-kind op
)
548 (operand-parse-name op
)))
549 (let ((target (find-operand (operand-parse-target op
) parse
550 '(:temporary
:result
))))
551 ;; KLUDGE: These formulas must be consistent with those in
552 ;; EMIT-VOP, and this is currently maintained by
553 ;; hand. -- WHN 2002-01-30, paraphrasing APD
554 (targets (+ (* index max-vop-tn-refs
)
555 (ecase (operand-parse-kind target
)
557 (+ (position-or-lose target
558 (vop-parse-results parse
))
561 (+ (* (position-or-lose target
562 (vop-parse-temps parse
))
567 (let ((born (operand-parse-born op
))
568 (dies (operand-parse-dies op
)))
569 (ecase (operand-parse-kind op
)
571 (refs (cons (cons dies nil
) index
)))
573 (refs (cons (cons dies nil
) index
)))
575 (refs (cons (cons born t
) index
)))
577 (refs (cons (cons born t
) index
)))
579 (refs (cons (cons dies nil
) index
))
581 (refs (cons (cons born t
) index
))))
583 (let* ((sorted (stable-sort (refs)
585 (let ((x-time (car x
))
587 (if (>= x-time y-time
)
588 (if (>= y-time x-time
)
589 (and (not (cdr x
)) (cdr y
))
593 ;; :REF-ORDERING element type
595 ;; KLUDGE: was (MOD #.MAX-VOP-TN-REFS), which is still right
596 (oe-type '(unsigned-byte 8))
597 ;; :TARGETS element-type
599 ;; KLUDGE: was (MOD #.(* MAX-VOP-TN-REFS 2)), which does
600 ;; not correspond to the definition in
601 ;; src/compiler/vop.lisp.
602 (te-type '(unsigned-byte 16))
603 (ordering (sb-xc:make-array
(length sorted
) :element-type oe-type
)))
606 (setf (aref ordering index
) (cdr ref
))
608 `(:num-args
,num-args
609 :num-results
,num-results
610 :ref-ordering
,ordering
612 `(:targets
,(coerce (targets) `(vector ,te-type
)))))))))
614 (defun make-emit-function-and-friends (parse)
615 `(:temps
,(compute-temporaries-description parse
)
616 ,@(compute-ref-ordering parse
)))
618 ;;;; generator functions
620 ;;; Return an alist that translates from lists of SCs we can load OP
621 ;;; from to the move function used for loading those SCs. We quietly
622 ;;; ignore restrictions to :non-packed (constant) and :unbounded SCs,
623 ;;; since we don't load into those SCs.
624 (defun find-move-funs (op load-p
)
626 (dolist (sc-name (operand-parse-scs op
))
627 (unless (or (consp sc-name
)
628 (getf *backend-cond-scs
* sc-name
))
629 (let* ((sc (sc-or-lose sc-name
))
631 (load-scs (append (when load-p
632 (sc-constant-scs sc
))
633 (sc-alternate-scs sc
))))
636 (dolist (alt load-scs
)
637 (unless (member (sc-name alt
) (operand-parse-scs op
) :test
#'eq
)
638 (let* ((altn (sc-number alt
))
640 (svref (sc-move-funs sc
) altn
)
641 (svref (sc-move-funs alt
) scn
)))
642 (found (or (assoc alt
(funs) :test
#'member
)
643 (rassoc name
(funs)))))
645 (error "no move function defined to ~:[save~;load~] SC ~S ~
646 ~:[to~;from~] from SC ~S"
647 load-p sc-name load-p
(sc-name alt
)))
649 (pushnew alt
(car found
)))
651 (funs (cons (list alt
) name
))))))))
652 ((member (sb-kind (sc-sb sc
)) '(:non-packed
:unbounded
)))
654 (error "SC ~S has no alternate~:[~; or constant~] SCs, yet it is~@
655 mentioned in the restriction for operand ~S"
656 sc-name load-p
(operand-parse-name op
)))))))
659 ;;; Return a form to load/save the specified operand when it has a
660 ;;; load TN. For any given SC that we can load from, there must be a
661 ;;; unique load function. If all SCs we can load from have the same
662 ;;; move function, then we just call that when there is a load TN. If
663 ;;; there are multiple possible move functions, then we dispatch off
664 ;;; of the operand TN's type to see which move function to use.
665 (defun call-move-fun (parse op load-p
)
666 (let ((funs (find-move-funs op load-p
))
667 (load-tn (operand-parse-load-tn op
)))
669 (let* ((tn `(tn-ref-tn ,(operand-parse-temp op
)))
670 (n-vop (vop-parse-vop-var parse
))
671 (form (if (rest funs
)
673 ,@(mapcar (lambda (x)
674 `(,(mapcar #'sc-name
(car x
))
676 `(,(cdr x
) ,n-vop
,tn
678 `(,(cdr x
) ,n-vop
,load-tn
682 `(,(cdr (first funs
)) ,n-vop
,tn
,load-tn
)
683 `(,(cdr (first funs
)) ,n-vop
,load-tn
,tn
)))))
686 ((eq (operand-parse-load op
) t
)
687 `(when ,load-tn
,form
))
689 `(when (eq ,load-tn
,(operand-parse-name op
))
692 (error "load TN allocated, but no move function?~@
693 VM definition is inconsistent, recompile and try again.")))))
695 ;;; Return the TN that we should bind to the operand's var in the
696 ;;; generator body. In general, this involves evaluating the :LOAD-IF
698 (defun decide-to-load (parse op
)
699 (let ((load (operand-parse-load op
))
700 (load-tn (operand-parse-load-tn op
))
701 (temp (operand-parse-temp op
))
702 (loads (and (eq (operand-parse-kind op
) :argument
)
703 (call-move-fun parse op t
))))
712 (dolist (x (vop-parse-operands parse
))
713 (when (member (operand-parse-kind x
) '(:argument
:result
))
714 (let ((name (operand-parse-name x
)))
715 (binds `(,name
(tn-ref-tn ,(operand-parse-temp x
))))
717 `(cond ((and ,load-tn
719 (declare (ignorable ,@(ignores)))
724 (tn-ref-tn ,temp
)))))))
726 ;;; Make a lambda that parses the VOP TN-REFS, does automatic operand
727 ;;; loading, and runs the appropriate code generator.
728 (defun make-generator-function (parse)
729 (declare (type vop-parse parse
))
730 (let ((n-vop (vop-parse-vop-var parse
))
731 (operands (vop-parse-operands parse
))
732 (n-info (gensym)) (n-variant (gensym))
737 (dolist (op operands
)
738 (ecase (operand-parse-kind op
)
740 (let ((temp (operand-parse-temp op
))
741 (name (operand-parse-name op
)))
742 (cond ((and (operand-parse-load op
) (operand-parse-scs op
))
743 (binds `(,(operand-parse-load-tn op
)
744 (tn-ref-load-tn ,temp
)))
745 (binds `(,name
,(decide-to-load parse op
)))
746 (when (eq (operand-parse-kind op
) :result
)
747 (saves (call-move-fun parse op nil
))))
749 (binds `(,name
(tn-ref-tn ,temp
)))))))
751 (binds `(,(operand-parse-name op
)
752 (tn-ref-tn ,(operand-parse-temp op
)))))
753 ((:more-argument
:more-result
))))
755 `(named-lambda (vop ,(vop-parse-name parse
)) (,n-vop
)
756 (declare (ignorable ,n-vop
))
757 (let* (,@(access-operands (vop-parse-args parse
)
758 (vop-parse-more-args parse
)
760 ,@(access-operands (vop-parse-results parse
)
761 (vop-parse-more-results parse
)
762 `(vop-results ,n-vop
))
763 ,@(access-operands (vop-parse-temps parse
) nil
765 ,@(when (vop-parse-info-args parse
)
766 `((,n-info
(vop-codegen-info ,n-vop
))
767 ,@(mapcar (lambda (x) `(,x
(pop ,n-info
)))
768 (vop-parse-info-args parse
))))
769 ,@(when (vop-parse-variant-vars parse
)
770 `((,n-variant
(vop-info-variant (vop-info ,n-vop
)))
771 ,@(mapcar (lambda (x) `(,x
(pop ,n-variant
)))
772 (vop-parse-variant-vars parse
))))
773 ,@(when (vop-parse-node-var parse
)
774 `((,(vop-parse-node-var parse
) (vop-node ,n-vop
))))
775 ,@(and (neq (vop-parse-before-load parse
) :unspecified
)
777 ,@(vop-parse-before-load parse
)))))
779 (declare (ignore ,@(vop-parse-ignores parse
)
780 ,@(and (neq (vop-parse-before-load parse
) :unspecified
)
783 ;; RETURN-FROM can exit the ASSEMBLE while continuing on with saves.
784 (block ,(vop-parse-name parse
)
786 ,@(vop-parse-body parse
)))
789 (defun make-after-sc-function (parse)
791 (remove-if-not #'operand-parse-unused-if
792 (vop-parse-temps parse
))))
794 (let* ((n-vop (vop-parse-vop-var parse
))
798 `(,@(access-operands (vop-parse-args parse
)
799 (vop-parse-more-args parse
)
801 ,@(access-operands (vop-parse-results parse
)
802 (vop-parse-more-results parse
)
803 `(vop-results ,n-vop
))
805 (access-operands (vop-parse-temps parse
) nil
806 `(vop-temps ,n-vop
)))
807 ,@(when (vop-parse-info-args parse
)
808 `((,n-info
(vop-codegen-info ,n-vop
))
809 ,@(mapcar (lambda (x) `(,x
(pop ,n-info
)))
810 (vop-parse-info-args parse
))))
811 ,@(when (vop-parse-variant-vars parse
)
812 `((,n-variant
(vop-info-variant (vop-info ,n-vop
)))
813 ,@(mapcar (lambda (x) `(,x
(pop ,n-variant
)))
814 (vop-parse-variant-vars parse
))))
815 ,@(loop for op in
(vop-parse-operands parse
)
817 (ecase (operand-parse-kind op
)
819 `(,(operand-parse-name op
)
820 (tn-ref-tn ,(operand-parse-temp op
))))
822 (and (operand-parse-unused-if op
)
823 `(,(operand-parse-name op
)
824 (tn-ref-tn ,(operand-parse-temp op
)))))
825 ((:more-argument
:more-result
)))
829 (declare (ignorable ,@(mapcar #'car bindings
)))
830 ,@(loop for op in unused-temps
831 collect
`(when ,(operand-parse-unused-if op
)
832 (setf (tn-kind ,(operand-parse-name op
)) :unused
)))))))))
834 (defvar *parse-vop-operand-count
*)
835 (defun make-operand-parse-temp ()
836 (symbolicate! #.
(find-package "SB-C") "OPERAND-PARSE-TEMP-"
837 *parse-vop-operand-count
*))
838 (defun make-operand-parse-load-tn ()
839 (symbolicate! #.
(find-package "SB-C")
840 "OPERAND-PARSE-LOAD-TN-" *parse-vop-operand-count
*))
842 ;;; Given a list of operand specifications as given to DEFINE-VOP,
843 ;;; return a list of OPERAND-PARSE structures describing the fixed
844 ;;; operands, and a single OPERAND-PARSE describing any more operand.
845 ;;; If we are inheriting a VOP, we default attributes to the inherited
846 ;;; operand of the same name.
847 (defun parse-vop-operands (parse specs kind
)
848 (declare (list specs
)
849 (type (member :argument
:result
) kind
))
852 (collect ((operands))
854 (unless (and (consp spec
) (symbolp (first spec
)) (oddp (length spec
)))
855 (error "malformed operand specifier: ~S" spec
))
857 (error "The MORE operand isn't the last operand: ~S" specs
))
858 (incf *parse-vop-operand-count
*)
860 (let* ((name (first spec
))
861 (old (if (vop-parse-inherits parse
)
864 (vop-parse-inherits parse
))
866 (if (eq kind
:argument
)
872 (nconc (list :kind kind
)
875 :target
(operand-parse-target old
)
876 :born
(operand-parse-born old
)
877 :dies
(operand-parse-dies old
)
878 :scs
(operand-parse-scs old
)
879 :load-tn
(operand-parse-load-tn old
)
880 :load
(operand-parse-load old
))
883 (list :born
(parse-time-spec :load
)
884 :dies
(parse-time-spec `(:argument
,num
))))
886 (list :born
(parse-time-spec `(:result
,num
))
887 :dies
(parse-time-spec :save
))))))))
888 (do ((tail (rest spec
) (cddr tail
)))
890 (let ((key (first tail
))
891 (value (second tail
)))
894 (aver (typep value
'list
))
895 (aver (= (length value
) (length (remove-duplicates value
))))
896 (setq value
(copy-list value
)))
898 (aver (typep value
'symbol
)))
902 (aver (typep value
'boolean
))
904 value
(if (eq kind
:argument
) :more-argument
:more-result
))
905 (setf (getf res
:load
) nil
)
908 (aver (typep value
'symbol
)))
910 (unless (eq kind
:result
)
911 (error "can only specify :FROM in a result: ~S" spec
))
912 (setq key
:born value
(parse-time-spec value
)))
914 (unless (eq kind
:argument
)
915 (error "can only specify :TO in an argument: ~S" spec
))
916 (setq key
:dies value
(parse-time-spec value
)))
918 (error "unknown keyword in operand specifier: ~S" spec
)))
919 (setf (getf res key
) value
)))
921 (setq res
(apply #'make-operand-parse
:name name res
)
922 more
(if more res nil
))
925 ((operand-parse-target more
)
926 (error "cannot specify :TARGET in a :MORE operand"))
927 ((operand-parse-load more
)
928 (error "cannot specify :LOAD-IF in a :MORE operand")))))
929 (values (the list
(operands)) more
))))
931 ;;; Parse a temporary specification, putting the OPERAND-PARSE
932 ;;; structures in the PARSE structure.
933 (defun parse-temporary (spec parse
)
935 (type vop-parse parse
))
936 (let ((len (length spec
)))
938 (error "malformed temporary spec: ~S" spec
))
939 (unless (listp (second spec
))
940 (error "malformed options list: ~S" (second spec
)))
941 (unless (evenp (length (second spec
)))
942 (error "odd number of arguments in keyword options: ~S" spec
))
943 (unless (consp (cddr spec
))
944 (warn "temporary spec allocates no temps:~% ~S" spec
))
945 (dolist (name (cddr spec
))
946 (unless (symbolp name
)
947 (error "bad temporary name: ~S" name
))
948 ;; It's almost always a mistake to have overlaps in the operand names.
949 ;; But I guess that some users think it's fine?
951 (when (member name
(vop-parse-temps parse
) :key
#'operand-parse-name
)
952 (warn "temp ~s already exists in ~s" name
(vop-parse-name parse
)))
953 (incf *parse-vop-operand-count
*)
954 (let ((res (list :born
(parse-time-spec :load
)
955 :dies
(parse-time-spec :save
))))
956 (do ((opt (second spec
) (cddr opt
)))
958 (let ((key (first opt
))
959 (value (second opt
)))
962 (setf value
(vop-spec-arg opt
'symbol
1 nil
)))
964 (setf key
:scs value
(vop-spec-arg opt
'symbol
1 nil
)))
966 (aver (typep (setq value
(eval value
)) 'unsigned-byte
)))
968 (setf key
:born value
(parse-time-spec value
)))
970 (setf key
:dies value
(parse-time-spec value
)))
971 ;; backward compatibility...
973 (let ((scs (vop-spec-arg opt
'list
1 nil
)))
974 (unless (= (length scs
) 1)
975 (error "must specify exactly one SC for a temporary"))
976 (setf value
(first scs
))))
979 (error "unknown temporary option: ~S" opt
)))
980 (setf (getf res key
) value
)))
982 (setq res
(apply #'make-operand-parse
:name name
:kind
:temporary res
))
983 (unless (and (>= (operand-parse-dies res
)
984 (operand-parse-born res
))
985 (< (operand-parse-born res
)
986 (operand-parse-dies res
)))
987 (error "Temporary lifetime doesn't begin before it ends: ~S" spec
))
989 (unless (operand-parse-scs res
)
990 (error "must specify :SC for all temporaries: ~S" spec
))
992 (setf (vop-parse-temps parse
)
994 (remove name
(vop-parse-temps parse
)
995 :key
#'operand-parse-name
))))))
998 (defun compute-parse-vop-operand-count (parse)
999 (declare (type vop-parse parse
))
1000 (labels ((compute-count-aux (parse)
1001 (declare (type vop-parse parse
))
1002 (if (null (vop-parse-inherits parse
))
1003 (length (vop-parse-operands parse
))
1004 (+ (length (vop-parse-operands parse
))
1006 (vop-parse-or-lose (vop-parse-inherits parse
)))))))
1007 (if (null (vop-parse-inherits parse
))
1009 (compute-count-aux (vop-parse-or-lose (vop-parse-inherits parse
))))))
1011 ;;; the top level parse function: clobber PARSE to represent the
1012 ;;; specified options.
1013 (defun parse-define-vop (parse specs inherits
)
1014 (declare (type vop-parse parse
) (list specs
))
1015 (let ((*parse-vop-operand-count
* (compute-parse-vop-operand-count parse
))
1022 (dolist (spec specs
)
1023 (unless (consp spec
)
1024 (error "malformed option specification: ~S" spec
))
1028 (multiple-value-bind (fixed more
)
1029 (parse-vop-operands parse
(rest spec
) :argument
)
1030 (setf (vop-parse-args parse
) fixed
)
1031 (setf (vop-parse-more-args parse
) more
)))
1034 (multiple-value-bind (fixed more
)
1035 (parse-vop-operands parse
(rest spec
) :result
)
1036 (setf (vop-parse-results parse
) fixed
)
1037 (setf (vop-parse-more-results parse
) more
))
1038 (setf (vop-parse-conditional-p parse
) nil
))
1040 (setf (vop-parse-result-types parse
) ())
1041 (setf (vop-parse-results parse
) ())
1042 (setf (vop-parse-more-results parse
) nil
)
1043 (setf (vop-parse-conditional-p parse
) (or (rest spec
) t
)))
1045 (parse-temporary spec parse
))
1047 (setf (vop-parse-cost parse
)
1048 (vop-spec-arg spec
'unsigned-byte
1 nil
))
1049 (setf (vop-parse-body parse
) (cddr spec
)))
1051 (setf (vop-parse-before-load parse
) (cdr spec
)))
1053 (setf (vop-parse-info-args parse
) (rest spec
)))
1055 (setf (vop-parse-ignores parse
)
1056 (append (vop-parse-ignores parse
)
1059 (setf (vop-parse-variant parse
) (rest spec
)))
1061 (let ((vars (rest spec
)))
1062 (setf (vop-parse-variant-vars parse
) vars
)
1063 (setf (vop-parse-variant parse
)
1064 (make-list (length vars
) :initial-element nil
))))
1066 (setf (vop-parse-cost parse
) (vop-spec-arg spec
'unsigned-byte
)))
1068 (setf (vop-parse-vop-var parse
) (vop-spec-arg spec
'symbol
)))
1071 arg-refs
(cdr spec
)))
1073 (setf result-refs-p t
1074 result-refs
(cdr spec
)))
1076 (setf (vop-parse-move-args parse
)
1077 (vop-spec-arg spec
'(member nil
:local-call
:full-call
1078 :known-return
:fixed
))))
1080 (setf (vop-parse-node-var parse
) (vop-spec-arg spec
'symbol
)))
1082 (setf (vop-parse-note parse
) (vop-spec-arg spec
'(or string null
))))
1084 (setf (vop-parse-arg-types parse
)
1085 (parse-vop-operand-types (rest spec
) t
)))
1087 (setf (vop-parse-result-types parse
)
1088 (parse-vop-operand-types (rest spec
) nil
)))
1090 (setf (vop-parse-translate parse
) (rest spec
)))
1092 (setf (vop-parse-guard parse
) (vop-spec-arg spec t
)))
1093 ;; FIXME: :LTN-POLICY would be a better name for this. It
1094 ;; would probably be good to leave it unchanged for a while,
1095 ;; though, at least until the first port to some other
1096 ;; architecture, since the renaming would be a change to the
1097 ;; interface between
1099 (setf (vop-parse-ltn-policy parse
)
1100 (vop-spec-arg spec
'ltn-policy
)))
1102 (setf (vop-parse-save-p parse
)
1104 '(member t nil
:compute-only
:force-to-stack
))))
1106 (setf (vop-parse-optional-results parse
)
1107 (append (vop-parse-optional-results parse
)
1110 (setf (vop-parse-gc-barrier parse
) (rest spec
)))
1112 (error "unknown option specifier: ~S" (first spec
)))))
1114 (loop with refs
= arg-refs
1115 for arg in
(if args-p
1116 (vop-parse-args parse
)
1117 (setf (vop-parse-args parse
)
1118 (mapcar #'copy-structure
(vop-parse-args parse
))))
1119 for ref
= (pop refs
)
1121 do
(setf (operand-parse-temp arg
) ref
)))
1124 (loop for inherited-arg in
(vop-parse-args inherits
)
1125 for arg in
(vop-parse-args parse
)
1126 do
(setf (operand-parse-temp arg
)
1127 (operand-parse-temp inherited-arg
)))))
1128 (cond (result-refs-p
1129 (loop with refs
= result-refs
1130 for result in
(if results-p
1131 (vop-parse-results parse
)
1132 (setf (vop-parse-results parse
)
1133 (mapcar #'copy-structure
(vop-parse-results parse
))))
1134 for ref
= (pop refs
)
1136 do
(setf (operand-parse-temp result
) ref
)))
1139 (loop for inherited-result in
(vop-parse-results inherits
)
1140 for result in
(vop-parse-results parse
)
1141 do
(setf (operand-parse-temp result
)
1142 (operand-parse-temp inherited-result
)))))
1145 ;;;; making costs and restrictions
1147 ;;; Given an operand, returns two values:
1148 ;;; 1. A SC-vector of the cost for the operand being in that SC,
1149 ;;; including both the costs for move functions and coercion VOPs.
1150 ;;; 2. A SC-vector holding the SC that we load into, for any SC
1151 ;;; that we can directly load from.
1153 ;;; In both vectors, unused entries are NIL. LOAD-P specifies the
1154 ;;; direction: if true, we are loading, if false we are saving.
1155 (defun compute-loading-costs (op load-p
)
1156 (declare (type operand-parse op
))
1157 (let ((scs (operand-parse-scs op
))
1158 (costs (make-array sb-vm
:sc-number-limit
:initial-element nil
))
1159 (load-scs (make-array sb-vm
:sc-number-limit
:initial-element nil
))
1161 (dolist (sc-name (reverse scs
))
1162 (let ((load-sc (gethash sc-name
*backend-sc-names
*)))
1164 (let* ((load-scn (sc-number load-sc
)))
1165 (setf (svref costs load-scn
) 0)
1166 (setf (svref load-scs load-scn
) t
)
1167 (dolist (op-sc (append (when load-p
1168 (sc-constant-scs load-sc
))
1169 (sc-alternate-scs load-sc
)))
1170 (let* ((op-scn (sc-number op-sc
))
1172 (aref (sc-load-costs load-sc
) op-scn
)
1173 (aref (sc-load-costs op-sc
) load-scn
))))
1175 (error "no move function defined to move ~:[from~;to~] SC ~
1176 ~S~%~:[to~;from~] alternate or constant SC ~S"
1177 load-p sc-name load-p
(sc-name op-sc
)))
1179 (let ((op-cost (svref costs op-scn
)))
1180 (when (or (not op-cost
) (< load op-cost
))
1181 (setf (svref costs op-scn
) load
)))
1183 (let ((op-load (svref load-scs op-scn
)))
1184 (unless (eq op-load t
)
1185 (pushnew load-scn
(svref load-scs op-scn
))))))
1187 (dotimes (i sb-vm
:sc-number-limit
)
1188 (unless (svref costs i
)
1189 (let ((op-sc (svref *backend-sc-numbers
* i
)))
1191 (let ((cost (if load-p
1192 (svref (sc-move-costs load-sc
) i
)
1193 (svref (sc-move-costs op-sc
) load-scn
))))
1195 (setf (svref costs i
) cost
)))))))))
1196 ((let ((cond-sc (getf *backend-cond-scs
* sc-name
)))
1198 (push cond-sc cond-scs
))))
1200 (push sc-name cond-scs
))
1202 (error "~S is not a defined storage class." sc-name
)))))
1204 (values costs load-scs
1205 (loop for
(cond-sc . test
) in cond-scs
1207 (let* ((load-sc (sc-or-lose cond-sc
))
1208 (load-scn (sc-number load-sc
)))
1209 `(setf (svref load-scs
,load-scn
)
1211 `(,test
',(svref load-scs load-scn
))
1215 ',(svref load-scs load-scn
))))))))))
1217 (defconstant-eqx +no-costs
+
1218 (make-array sb-vm
:sc-number-limit
:initial-element
0)
1221 (defconstant-eqx +no-loads
+
1222 (make-array sb-vm
:sc-number-limit
:initial-element t
)
1225 ;;; Pick off the case of operands with no restrictions.
1226 (defun compute-loading-costs-if-any (op load-p
)
1227 (declare (type operand-parse op
))
1228 (if (operand-parse-scs op
)
1229 (compute-loading-costs op load-p
)
1230 (values +no-costs
+ +no-loads
+)))
1232 (defun compute-costs-and-restrictions-list (ops load-p
)
1233 (declare (list ops
))
1238 (multiple-value-bind (costs scs fixup
) (compute-loading-costs-if-any op load-p
)
1242 (scs `(let ((load-scs (vector ,@(loop for sc across scs
1248 (values (costs) (scs) fixups
))))
1250 (defun make-costs-and-restrictions (parse)
1251 (multiple-value-bind (arg-costs arg-scs fixups
)
1252 (compute-costs-and-restrictions-list (vop-parse-args parse
) t
)
1253 (multiple-value-bind (result-costs result-scs
)
1254 (compute-costs-and-restrictions-list (vop-parse-results parse
) nil
)
1255 (multiple-value-bind (more-arg-costs more-arg-scs
)
1256 (and (vop-parse-more-args parse
)
1257 (compute-loading-costs-if-any (vop-parse-more-args parse
) t
))
1258 `(:cost
,(vop-parse-cost parse
)
1260 :arg-costs
',arg-costs
1261 :arg-load-scs
,(if fixups
1264 :result-costs
',result-costs
1265 :result-load-scs
',result-scs
1267 :more-arg-costs
',more-arg-costs
1268 :more-arg-load-scs
',(unless (eq more-arg-costs
+no-costs
+)
1269 (substitute-if nil
#'listp more-arg-scs
))
1272 ',(if (vop-parse-more-results parse
)
1273 (compute-loading-costs-if-any (vop-parse-more-results parse
) nil
)
1275 :optional-results
',(loop for name in
(vop-parse-optional-results parse
)
1276 collect
(position name
(vop-parse-results parse
) :key
#'operand-parse-name
)))))))
1278 ;;;; operand checking and stuff
1280 ;;; Given a list of arg/result restrictions, check for valid syntax
1281 ;;; and convert to canonical form.
1282 (defun parse-vop-operand-types (specs args-p
)
1283 (declare (list specs
))
1284 (labels ((primtype-alias-p (spec)
1285 (cdr (assq spec
*backend-primitive-type-aliases
*)))
1286 (parse-operand-type (spec)
1287 (cond ((eq spec
'*) spec
)
1289 (let ((alias (primtype-alias-p spec
)))
1291 (parse-operand-type alias
)
1294 (error "bad thing to be a operand type: ~S" spec
))
1298 (collect ((results))
1299 (dolist (item (cdr spec
))
1300 (unless (symbolp item
)
1301 (error "bad PRIMITIVE-TYPE name in ~S: ~S"
1303 (let ((alias (primtype-alias-p item
)))
1305 (let ((alias (parse-operand-type alias
)))
1306 (unless (eq (car alias
) :or
)
1307 (error "can't include primitive-type ~
1308 alias ~S in an :OR restriction: ~S"
1310 (dolist (x (cdr alias
))
1313 `(:or
,@(remove-duplicates (results) :test
#'eq
))))
1316 (error "can't :CONSTANT for a result"))
1317 (unless (= (length spec
) 2)
1318 (error "bad :CONSTANT argument type spec: ~S" spec
))
1321 (error "bad thing to be a operand type: ~S" spec
)))))))
1322 (mapcar #'parse-operand-type specs
)))
1324 ;;; Check the consistency of OP's SC restrictions with the specified
1325 ;;; primitive-type restriction. :CONSTANT operands have already been
1326 ;;; filtered out, so only :OR and * restrictions are left.
1328 ;;; We check that every representation allowed by the type can be
1329 ;;; directly loaded into some SC in the restriction, and that the type
1330 ;;; allows every SC in the restriction. With *, we require that T
1331 ;;; satisfy the first test, and omit the second.
1332 (defun check-operand-type-scs (parse op type load-p
)
1333 (declare (type vop-parse parse
) (type operand-parse op
))
1334 (let ((ptypes (if (eq type
'*) (list t
) (rest type
)))
1335 (scs (operand-parse-scs op
)))
1337 (multiple-value-bind (costs load-scs
) (compute-loading-costs op load-p
)
1338 (declare (ignore costs
))
1339 (dolist (ptype ptypes
)
1340 (unless (dolist (rep (primitive-type-scs
1341 (primitive-type-or-lose ptype
))
1343 (when (svref load-scs rep
) (return t
)))
1344 (error "In the ~A ~:[result~;argument~] to VOP ~S,~@
1345 none of the SCs allowed by the operand type ~S can ~
1346 directly be loaded~@
1347 into any of the restriction's SCs:~% ~S~:[~;~@
1348 [* type operand must allow T's SCs.]~]"
1349 (operand-parse-name op
) load-p
(vop-parse-name parse
)
1351 scs
(eq type
'*)))))
1354 (unless (or (eq type
'*)
1355 (dolist (ptype ptypes nil
)
1356 (when (sc-allowed-by-primitive-type
1357 (or (gethash (if (consp sc
)
1361 (sc-or-lose (car (getf *backend-cond-scs
* sc
)))
1362 (error "~S is not a defined storage class." sc
))
1363 (primitive-type-or-lose ptype
))
1366 (eq sc
'sb-vm
::zero
))
1367 (warn "~:[Result~;Argument~] ~A to VOP ~S~@
1368 has SC restriction ~S which is ~
1369 not allowed by the operand type:~% ~S"
1370 load-p
(operand-parse-name op
) (vop-parse-name parse
)
1375 ;;; If the operand types are specified, then check the number specified
1376 ;;; against the number of defined operands.
1377 (defun check-operand-types (parse ops more-op types load-p
)
1378 (declare (type vop-parse parse
) (list ops
)
1379 (type (or list
(member :unspecified
)) types
)
1380 (type (or operand-parse null
) more-op
))
1381 (unless (eq types
:unspecified
)
1382 (let ((num (+ (length ops
) (if more-op
1 0))))
1383 (unless (= (count-if-not (lambda (x)
1385 (eq (car x
) :constant
)))
1388 (error "expected ~W ~:[result~;argument~] type~P: ~S"
1389 num load-p types num
)))
1392 (let ((mtype (car (last types
))))
1393 (when (and (consp mtype
) (eq (first mtype
) :constant
))
1394 (error "can't use :CONSTANT on VOP more args")))))
1396 (when (vop-parse-translate parse
)
1397 (let ((types (specify-operand-types types ops more-op
)))
1399 (check-operand-type-scs parse x y load-p
))
1400 (if more-op
(butlast ops
) ops
)
1401 (remove-if (lambda (x)
1403 (eq (car x
) ':constant
)))
1404 (if more-op
(butlast types
) types
)))))
1408 (defun set-vop-parse-operands (parse)
1409 (declare (type vop-parse parse
))
1410 (setf (vop-parse-operands parse
)
1411 (append (vop-parse-args parse
)
1412 (if (vop-parse-more-args parse
)
1413 (list (vop-parse-more-args parse
)))
1414 (vop-parse-results parse
)
1415 (if (vop-parse-more-results parse
)
1416 (list (vop-parse-more-results parse
)))
1417 (vop-parse-temps parse
))))
1419 ;;;; function translation stuff
1421 ;;; Return forms to establish this VOP as a IR2 translation template
1422 ;;; for the :TRANSLATE functions specified in the VOP-PARSE. We also
1423 ;;; set the PREDICATE attribute for each translated function when the
1424 ;;; VOP is conditional, causing IR1 conversion to ensure that a call
1425 ;;; to the translated is always used in a predicate position.
1426 (defun set-up-fun-translation (parse n-template
)
1427 (declare (type vop-parse parse
))
1428 (mapcar (lambda (name)
1429 `(let ((info (fun-info-or-lose ',name
)))
1430 (setf (fun-info-templates info
)
1431 (adjoin-template ,n-template
(fun-info-templates info
)))
1432 ,@(when (vop-parse-conditional-p parse
)
1433 '((setf (fun-info-attributes info
)
1435 (ir1-attributes predicate
)
1436 (fun-info-attributes info
)))))))
1437 (vop-parse-translate parse
)))
1439 ;;; Return a form that can be evaluated to get the TEMPLATE operand type
1440 ;;; restriction from the given specification.
1441 (defun make-operand-type (type)
1442 (cond ((eq type
'*) ''*)
1444 ``(:or
,(primitive-type-or-lose ',type
)))
1448 ``(:or
,,@(mapcar (lambda (type)
1449 `(primitive-type-or-lose ',type
))
1452 ``(:constant .
,',(second type
)))))))
1454 (defun specify-operand-types (types ops more-ops
)
1455 (if (eq types
:unspecified
)
1456 (make-list (+ (length ops
) (if more-ops
1 0)) :initial-element
'*)
1459 ;;; Return a list of forms to use as &KEY args to MAKE-VOP-INFO for
1460 ;;; setting up the template argument and result types. Here we make an
1461 ;;; initial dummy TEMPLATE-TYPE, since it is awkward to compute the
1462 ;;; type until the template has been made.
1463 (defun make-vop-info-types (parse)
1464 (let* ((more-args (vop-parse-more-args parse
))
1465 (all-args (specify-operand-types (vop-parse-arg-types parse
)
1466 (vop-parse-args parse
)
1468 (args (if more-args
(butlast all-args
) all-args
))
1469 (more-arg (when more-args
(car (last all-args
))))
1470 (more-results (vop-parse-more-results parse
))
1471 (all-results (specify-operand-types (vop-parse-result-types parse
)
1472 (vop-parse-results parse
)
1474 (results (if more-results
(butlast all-results
) all-results
))
1475 (more-result (when more-results
(car (last all-results
))))
1476 (conditional (vop-parse-conditional-p parse
)))
1478 `(:type
(specifier-type '(function () nil
))
1479 :arg-types
(list ,@(mapcar #'make-operand-type args
))
1480 :more-args-type
,(when more-args
(make-operand-type more-arg
))
1481 :result-types
,(cond ((eq conditional t
)
1484 `'(:conditional .
,conditional
))
1486 `(list ,@(mapcar #'make-operand-type results
))))
1487 :more-results-type
,(when more-results
1488 (make-operand-type more-result
)))))
1490 ;;;; setting up VOP-INFO
1492 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
1493 (defparameter *slot-inherit-alist
*
1494 '((:generator-function . vop-info-generator-function
))))
1496 ;;; This is something to help with inheriting VOP-INFO slots. We
1497 ;;; return a keyword/value pair that can be passed to the constructor.
1498 ;;; SLOT is the keyword name of the slot, Parse is a form that
1499 ;;; evaluates to the VOP-PARSE structure for the VOP inherited. If
1500 ;;; PARSE is NIL, then we do nothing. If the TEST form evaluates to
1501 ;;; true, then we return a form that selects the named slot from the
1502 ;;; VOP-INFO structure corresponding to PARSE. Otherwise, we return
1503 ;;; the FORM so that the slot is recomputed.
1504 (defmacro inherit-vop-info
(slot parse test form
)
1505 `(if (and ,parse
,test
)
1506 (list ,slot
`(,',(or (cdr (assoc slot
*slot-inherit-alist
*))
1507 (error "unknown slot ~S" slot
))
1508 (template-or-lose ',(vop-parse-name ,parse
))))
1509 (list ,slot
,form
)))
1511 ;;; Return a form that creates a VOP-INFO structure which describes VOP.
1512 (defun set-up-vop-info (iparse parse
)
1513 (declare (type vop-parse parse
) (type (or vop-parse null
) iparse
))
1514 (let ((same-operands
1516 (equal (vop-parse-operands parse
)
1517 (vop-parse-operands iparse
))
1518 (equal (vop-parse-info-args iparse
)
1519 (vop-parse-info-args parse
))))
1520 (variant (vop-parse-variant parse
)))
1522 (let ((nvars (length (vop-parse-variant-vars parse
))))
1523 (unless (= (length variant
) nvars
)
1524 (error "expected ~W variant values: ~S" nvars variant
)))
1527 :name
',(vop-parse-name parse
)
1528 ,@(make-vop-info-types parse
)
1529 :guard
,(awhen (vop-parse-guard parse
)
1530 (if (typep it
'(cons (eql lambda
)))
1532 `(lambda (node) (declare (ignore node
)) ,it
)))
1533 :note
',(vop-parse-note parse
)
1534 :info-arg-count
,(- (length (vop-parse-info-args parse
))
1535 (if (vop-parse-gc-barrier parse
)
1538 :ltn-policy
',(vop-parse-ltn-policy parse
)
1539 :save-p
',(vop-parse-save-p parse
)
1540 :move-args
',(vop-parse-move-args parse
)
1541 ,@(make-costs-and-restrictions parse
)
1542 ,@(make-emit-function-and-friends parse
)
1543 ,@(inherit-vop-info :generator-function iparse
1545 (equal (vop-parse-body parse
) (vop-parse-body iparse
)))
1546 (unless (eq (vop-parse-body parse
) :unspecified
)
1547 (make-generator-function parse
)))
1548 :variant
(list ,@variant
)
1550 ;; TODO: inherit it?
1551 ,(make-after-sc-function parse
)
1552 :gc-barrier
',(vop-parse-gc-barrier parse
))))
1554 ;;; Define the symbol NAME to be a Virtual OPeration in the compiler.
1555 ;;; If specified, INHERITS is the name of a VOP that we default
1556 ;;; unspecified information from. Each SPEC is a list beginning with a
1557 ;;; keyword indicating the interpretation of the other forms in the
1560 ;;; :ARGS {(Name {Key Value}*)}*
1561 ;;; :RESULTS {(Name {Key Value}*)}*
1562 ;;; The Args and Results are specifications of the operand TNs passed
1563 ;;; to the VOP. If there is an inherited VOP, any unspecified options
1564 ;;; are defaulted from the inherited argument (or result) of the same
1565 ;;; name. The following operand options are defined:
1568 ;;; :SCs specifies good SCs for this operand. Other SCs will
1569 ;;; be penalized according to move costs. A load TN will be
1570 ;;; allocated if necessary, guaranteeing that the operand is
1571 ;;; always one of the specified SCs.
1573 ;;; :LOAD-TN Load-Name
1574 ;;; Load-Name is bound to the load TN allocated for this
1575 ;;; operand, or to NIL if no load TN was allocated.
1577 ;;; :LOAD-IF EXPRESSION
1578 ;;; Controls whether automatic operand loading is done.
1579 ;;; EXPRESSION is evaluated with the fixed operand TNs bound.
1580 ;;; If EXPRESSION is true, then loading is done and the variable
1581 ;;; is bound to the load TN in the generator body. Otherwise,
1582 ;;; loading is not done, and the variable is bound to the actual
1586 ;;; If specified, NAME is bound to the TN-REF for the first
1587 ;;; argument or result following the fixed arguments or results.
1588 ;;; A :MORE operand must appear last, and cannot be targeted or
1592 ;;; This operand is targeted to the named operand, indicating a
1593 ;;; desire to pack in the same location. Not legal for results.
1597 ;;; Specify the beginning or end of the operand's lifetime.
1598 ;;; :FROM can only be used with results, and :TO only with
1599 ;;; arguments. The default for the N'th argument/result is
1600 ;;; (:ARGUMENT N)/(:RESULT N). These options are necessary
1601 ;;; primarily when operands are read or written out of order.
1603 ;;; :CONDITIONAL [Condition-descriptor+]
1604 ;;; This is used in place of :RESULTS with conditional branch VOPs.
1605 ;;; There are no result values: the result is a transfer of control.
1606 ;;; The target label is passed as the first :INFO arg. The second
1607 ;;; :INFO arg is true if the sense of the test should be negated.
1608 ;;; A side effect is to set the PREDICATE attribute for functions
1609 ;;; in the :TRANSLATE option.
1611 ;;; If some condition descriptors are provided, this is a flag-setting
1612 ;;; VOP. Descriptors are interpreted in an architecture-dependent
1613 ;;; manner. See the BRANCH-IF VOP in $ARCH/pred.lisp.
1615 ;;; :TEMPORARY ({Key Value}*) Name*
1616 ;;; Allocate a temporary TN for each Name, binding that variable to
1617 ;;; the TN within the body of the generators. In addition to :TARGET
1618 ;;; (which is is the same as for operands), the following options are
1622 ;;; :OFFSET SB-Offset
1623 ;;; Force the temporary to be allocated in the specified SC
1624 ;;; with the specified offset. Offset is evaluated at
1625 ;;; macroexpand time. If Offset is omitted, the register
1626 ;;; allocator chooses a free location in SC. If both SC and
1627 ;;; Offset are omitted, then the temporary is packed according
1628 ;;; to its primitive type.
1632 ;;; Similar to the argument/result option, this specifies the
1633 ;;; start and end of the temporaries' lives. The defaults are
1634 ;;; :LOAD and :SAVE, i.e. the duration of the VOP. The other
1635 ;;; intervening phases are :ARGUMENT, :EVAL and :RESULT.
1636 ;;; Non-zero sub-phases can be specified by a list, e.g. by
1637 ;;; default the second argument's life ends at (:ARGUMENT 1).
1639 ;;; :GENERATOR Cost Form*
1640 ;;; Specifies the translation into assembly code. Cost is the
1641 ;;; estimated cost of the code emitted by this generator. The body
1642 ;;; is arbitrary Lisp code that emits the assembly language
1643 ;;; translation of the VOP. An ASSEMBLE form is wrapped around
1644 ;;; the body, so code may be emitted by using the local INST macro.
1645 ;;; During the evaluation of the body, the names of the operands
1646 ;;; and temporaries are bound to the actual TNs.
1649 ;;; Define some magic arguments that are passed directly to the code
1650 ;;; generator. The corresponding trailing arguments to VOP or
1651 ;;; %PRIMITIVE are stored in the VOP structure. Within the body
1652 ;;; of the generators, the named variables are bound to these
1653 ;;; values. Except in the case of :CONDITIONAL VOPs, :INFO arguments
1654 ;;; cannot be specified for VOPS that are the direct translation
1655 ;;; for a function (specified by :TRANSLATE).
1658 ;;; Causes the named variables to be declared IGNORE in the
1662 ;;; :VARIANT-VARS Name*
1663 ;;; These options provide a way to parameterize families of VOPs
1664 ;;; that differ only trivially. :VARIANT makes the specified
1665 ;;; evaluated Things be the "variant" associated with this VOP.
1666 ;;; :VARIANT-VARS causes the named variables to be bound to the
1667 ;;; corresponding Things within the body of the generator.
1669 ;;; :VARIANT-COST Cost
1670 ;;; Specifies the cost of this VOP, overriding the cost of any
1671 ;;; inherited generator.
1673 ;;; :NOTE {String | NIL}
1674 ;;; A short noun-like phrase describing what this VOP "does", i.e.
1675 ;;; the implementation strategy. If supplied, efficiency notes will
1676 ;;; be generated when type uncertainty prevents :TRANSLATE from
1677 ;;; working. NIL inhibits any efficiency note.
1679 ;;; :ARG-TYPES {* | PType | (:OR PType*) | (:CONSTANT Type)}*
1680 ;;; :RESULT-TYPES {* | PType | (:OR PType*)}*
1681 ;;; Specify the template type restrictions used for automatic
1682 ;;; translation. If there is a :MORE operand, the last type is the
1683 ;;; more type. :CONSTANT specifies that the argument must be a
1684 ;;; compile-time constant of the specified Lisp type. The constant
1685 ;;; values of :CONSTANT arguments are passed as additional :INFO
1686 ;;; arguments rather than as :ARGS.
1688 ;;; :TRANSLATE Name*
1689 ;;; This option causes the VOP template to be entered as an IR2
1690 ;;; translation for the named functions.
1692 ;;; :POLICY {:SMALL | :SMALL-SAFE | :FAST | :SAFE | :FAST-SAFE}
1693 ;;; Specifies the policy under which this VOP is the best translation.
1696 ;;; Specifies a Form that is evaluated in the global environment.
1697 ;;; If form returns NIL, then emission of this VOP is prohibited
1698 ;;; even when all other restrictions are met.
1699 ;;; As an additional possibility, if Form is a lambda expression,
1700 ;;; then it is funcalled with the node under consideration.
1704 ;;; In the generator, bind the specified variable to the VOP or
1705 ;;; the Node that generated this VOP.
1707 ;;; :SAVE-P {NIL | T | :COMPUTE-ONLY | :FORCE-TO-STACK}
1708 ;;; Indicates how a VOP wants live registers saved.
1710 ;;; :MOVE-ARGS {NIL | :FULL-CALL | :LOCAL-CALL | :KNOWN-RETURN}
1711 ;;; Indicates if and how the more args should be moved into a
1712 ;;; different frame.
1713 (defmacro define-vop
((&optional name inherits
) &body specs
)
1714 (%define-vop name inherits specs t
))
1716 (defun %define-vop
(name inherits specs set
)
1717 (declare (type symbol name
))
1718 ;; Parse the syntax into a VOP-PARSE structure, and then expand into
1719 ;; code that creates the appropriate VOP-INFO structure at load time.
1720 ;; We implement inheritance by copying the VOP-PARSE structure for
1721 ;; the inherited structure.
1722 (let* ((inherited-parse (when inherits
1723 (vop-parse-or-lose inherits
)))
1725 (copy-vop-parse inherited-parse
)
1729 (let ((clause (assoc :translate specs
)))
1730 (when (singleton-p (cdr clause
))
1731 (setf name
(cadr clause
)))))
1733 (aver (typep name
'(and symbol
(not null
))))
1734 (setf (vop-parse-name parse
) name
))
1735 (setf (vop-parse-inherits parse
) inherits
)
1737 (parse-define-vop parse specs inherited-parse
)
1738 (set-vop-parse-operands parse
)
1739 (check-operand-types parse
1740 (vop-parse-args parse
)
1741 (vop-parse-more-args parse
)
1742 (vop-parse-arg-types parse
)
1744 (check-operand-types parse
1745 (vop-parse-results parse
)
1746 (vop-parse-more-results parse
)
1747 (vop-parse-result-types parse
)
1751 (eval-when (:compile-toplevel
)
1752 (setf (gethash ',name
*backend-parsed-vops
*) ',parse
))
1757 (dolist (x vop-parse-slot-names
(cons 'list
(forms)))
1758 (let ((reader (package-symbolicate (sb-xc:symbol-package
'vop-parse
)
1762 (source-location ''(source-location))
1763 ((temps args results
) `(quotify-list (,reader parse
)))
1764 ((more-args more-results
) `(quotify (,reader parse
)))
1765 (t `(list 'quote
(,reader parse
))))))))))
1766 (labels ((quotify (operand-or-nil)
1767 (when operand-or-nil
1768 (list 'quote
(quotify-1 operand-or-nil
))))
1769 (quotify-list (operands)
1770 (list 'quote
(mapcar #'quotify-1 operands
)))
1771 (quotify-1 (x) ; Return everything except the KIND, quoted
1772 `(,(operand-parse-name x
)
1773 ,(operand-parse-target x
) ,(operand-parse-temp x
)
1774 ,(operand-parse-born x
) ,(operand-parse-dies x
)
1775 ,(operand-parse-load-tn x
) ,(operand-parse-load x
)
1776 ,(operand-parse-scs x
) ,(operand-parse-offset x
))))
1778 ,@(unless (eq (vop-parse-body parse
) :unspecified
)
1779 `((let ((,n-res
,(set-up-vop-info inherited-parse parse
)))
1780 (store-vop-info ,n-res
)
1781 ,@(set-up-fun-translation parse n-res
))))
1783 `(let ((info ,(set-up-vop-info inherited-parse parse
)))
1784 (setf (vop-info-type info
)
1785 (specifier-type (template-type-specifier info
)))
1789 ;;; (((param unsigned-reg unsigned-num :to :save) arg)
1790 ;;; ((temp unsigned-reg unsigned-num))
1791 ;;; ((temp2))) ;; will reuse the previous specifications
1792 ;;; ((result unsigned-reg unsigned-num))
1793 ;;; (inst x result temp param))
1794 (defmacro inline-vop
(vars results
&body body
)
1802 (flet ((sc-to-primtype (sc)
1806 (sb-vm::unsigned-reg
1807 'sb-vm
::unsigned-num
)
1811 'system-area-pointer
)
1812 (sb-vm::descriptor-reg
1818 (sb-vm::complex-double-reg
1819 'complex-double-float
)
1820 (sb-vm::complex-single-reg
1821 'complex-single-float
)
1824 (primtype-to-type (type)
1826 (sb-vm::unsigned-num
1832 (complex-double-float
1833 '(complex double-float
))
1834 (complex-single-float
1835 '(complex single-float
))
1837 (t (primitive-type-specifier (primitive-type-or-lose type
))))))
1838 (loop for
(var arg
) in vars
1839 for
(name this-sc
) = var
1840 for
(nil sc type . rest
) = (if this-sc
1843 for prev
= (if this-sc
1846 do
(cond ((eq name
:info
)
1850 (args (list* name
:scs
(list sc
) rest
))
1851 (let ((type (or type
(sc-to-primtype sc
))))
1853 (input `(the ,(primtype-to-type type
) ,arg
))))
1855 (temps `(:temporary
(:sc
,sc
,@rest
)
1857 (loop for result in results
1858 for
(name this-sc
) = result
1859 for
(nil sc type . rest
) = (if this-sc
1862 for prev
= (if this-sc
1865 do
(results (list* name
:scs
(list sc
) rest
))
1866 (result-types (or type
(sc-to-primtype sc
))))
1868 (values ,@(mapcar #'primtype-to-type
(result-types)) &optional
)
1870 ,(eval (%define-vop nil nil
1873 (list* :args
(args)))
1875 (list* :arg-types
(arg-types)))
1877 (list* :results
(results)))
1879 (list* :result-types
(result-types)))
1881 (list* :info
(infos)))
1882 (list* :generator
0 body
)
1889 `(defun register-vop-parse ,vop-parse-slot-names
1890 ;; Try to share each OPERAND-PARSE structure with a similar existing one.
1891 (labels ((share-list (operand-specs accessor kind
)
1892 (let ((new (mapcar (lambda (x) (share x kind
)) operand-specs
)))
1893 (dohash ((key parse
) *backend-parsed-vops
* :result new
)
1894 (declare (ignore key
))
1895 (when (equal (funcall accessor parse
) new
)
1896 (return (funcall accessor parse
))))))
1897 (share (operand-spec kind
)
1898 ;; OPERAND-PARSE structures are immutable. Scan all vops for one
1899 ;; with an operand matching OPERAND-SPEC, and use that if found.
1900 (destructuring-bind (name targ temp born dies load-tn load scs offs
)
1902 (let ((op (make-operand-parse
1903 :name name
:kind kind
:target targ
:temp temp
1904 :born born
:dies dies
:load-tn load-tn
:load load
1905 :scs scs
:offset offs
)))
1906 (dohash ((key parse
) *backend-parsed-vops
* :result op
)
1907 (declare (ignore key
))
1908 (awhen (find op
(vop-parse-operands parse
) :test
#'operand
=)
1911 ;; EQUALP is too weak a comparator for arbitrary sexprs,
1912 ;; since (EQUALP "foo" #(#\F #\O #\O)) is T, not that
1913 ;; we expect such weirdness in the LOAD-IF expression.
1914 (and (equal (operand-parse-load a
) (operand-parse-load b
))
1916 (setq temps
(share-list temps
#'vop-parse-temps
:temporary
)
1917 args
(share-list args
#'vop-parse-args
:argument
)
1918 results
(share-list results
#'vop-parse-results
:result
))
1919 (when more-args
(setq more-args
(share more-args
:more-argument
)))
1920 (when more-results
(setq more-results
(share more-results
:more-result
))))
1922 (make-vop-parse ,@(mapcan (lambda (x) (list (keywordicate x
) x
))
1923 vop-parse-slot-names
))))
1924 (set-vop-parse-operands parse
)
1925 (setf (gethash name
*backend-parsed-vops
*) parse
)))))
1928 (defun store-vop-info (vop-info)
1929 ;; This is an inefficent way to perform coalescing, but it doesn't matter.
1930 (let* ((my-type-spec (template-type-specifier vop-info
))
1931 (my-type (specifier-type my-type-spec
)))
1932 (unless (block found
1933 (maphash (lambda (name other
)
1934 (declare (ignore name
))
1935 ;; we get better coaelesecing by TYPE= rather than
1936 ;; EQUALP on (template-type-specifier vop-info)
1937 ;; because some types have multiple spellings.
1938 (when (type= (vop-info-type other
) my-type
)
1939 (setf (vop-info-type vop-info
) (vop-info-type other
))
1940 (return-from found t
)))
1941 *backend-template-names
*))
1942 (setf (vop-info-type vop-info
) (specifier-type my-type-spec
))))
1943 (flet ((find-equalp (accessor)
1944 ;; Read the slot from VOP-INFO and try to find any other vop-info
1945 ;; that has an EQUALP value in that slot, returning that value.
1946 ;; Failing that, try again at a finer grain.
1947 (let ((my-val (funcall accessor vop-info
))) ; list of vectors
1948 (maphash (lambda (name other
)
1949 (declare (ignore name
))
1950 (let ((other-val (funcall accessor other
)))
1951 (when (equalp other-val my-val
)
1952 (return-from find-equalp other-val
))))
1953 *backend-template-names
*)
1954 (unless (and (listp my-val
) (vectorp (car my-val
)))
1955 (return-from find-equalp my-val
))
1956 (mapl (lambda (cell)
1957 (let ((my-vector (car cell
)))
1959 (maphash (lambda (name other
)
1960 (declare (ignore name
))
1961 (dolist (other-vector
1962 (funcall accessor other
))
1963 (when (equalp other-vector my-vector
)
1964 (rplaca cell other-vector
)
1965 (return-from found
))))
1966 *backend-template-names
*))))
1967 (copy-list my-val
))))) ; was a quoted constant, don't mutate
1968 (macrolet ((try-coalescing (accessor)
1969 `(setf (,accessor vop-info
) (find-equalp #',accessor
))))
1970 (try-coalescing vop-info-arg-types
)
1971 (try-coalescing vop-info-arg-costs
)
1972 (try-coalescing vop-info-arg-load-scs
)
1973 (try-coalescing vop-info-result-types
)
1974 (try-coalescing vop-info-result-costs
)
1975 (try-coalescing vop-info-result-load-scs
)
1976 (try-coalescing vop-info-more-arg-costs
)
1977 (try-coalescing vop-info-more-result-costs
)
1978 (try-coalescing vop-info-temps
)
1979 (try-coalescing vop-info-ref-ordering
)
1980 (try-coalescing vop-info-targets
)))
1981 ;; vop rdefinition should be allowed, but a dup in the cross-compiler
1982 ;; is probably a mistake. REGISTER-VOP-PARSE is the wrong place
1983 ;; to check this, because parsing has both compile-time and load-time
1984 ;; effects, since inheritance is computed at compile-time.
1985 ;; And there are false positives with any DEFINE-VOP in an assembler file
1986 ;; because those are processed twice. I don't know what to do.
1987 #+nil
(when (gethash (vop-info-name vop-info
) *backend-template-names
*)
1988 (warn "Duplicate vop name: ~s" vop-info
))
1989 (setf (gethash (vop-info-name vop-info
) *backend-template-names
*)
1992 (defun undefine-vop (name)
1993 (let ((parse (gethash name
*backend-parsed-vops
*)))
1994 (dolist (translate (vop-parse-translate parse
))
1995 (let ((info (info :function
:info translate
)))
1996 (setf (fun-info-templates info
)
1997 (delete name
(fun-info-templates info
)
1998 :key
#'vop-info-name
))
1999 (format t
"~&~s has ~d templates~%" translate
(length (fun-info-templates info
)))))
2000 (remhash name
*backend-parsed-vops
*)
2001 (remhash name
*backend-template-names
*)))
2003 ;;;; emission macros
2005 ;;; Return code to make a list of VOP arguments or results, linked by
2006 ;;; TN-REF-ACROSS. The first value is code, the second value is LET*
2007 ;;; forms, and the third value is a variable that evaluates to the
2008 ;;; head of the list, or NIL if there are no operands. Fixed is a list
2009 ;;; of forms that evaluate to TNs for the fixed operands. TN-REFS will
2010 ;;; be made for these operands according using the specified value of
2011 ;;; WRITE-P. More is an expression that evaluates to a list of TN-REFS
2012 ;;; that will be made the tail of the list. If it is constant NIL,
2013 ;;; then we don't bother to set the tail.
2014 (defun make-operand-list (fixed more write-p
)
2020 (multiple-value-bind (op lvar
)
2021 (if (typep op
'(cons (eql :lvar
)))
2022 (values (third op
) (second op
))
2024 (let ((n-ref (gensym)))
2025 (binds `(,n-ref
(reference-tn ,op
,write-p
)))
2027 (forms `(setf (tn-ref-type ,n-ref
) (lvar-type ,lvar
))))
2029 (forms `(setf (tn-ref-across ,n-prev
) ,n-ref
))
2030 (setq n-head n-ref
))
2031 (setq n-prev n-ref
))))
2034 (let ((n-more (gensym)))
2035 (binds `(,n-more
,more
))
2037 (forms `(setf (tn-ref-across ,n-prev
) ,n-more
))
2038 (setq n-head n-more
))))
2040 (values (forms) (binds) n-head
))))
2042 ;;; Emit-Template Node Block Template Args Results [Info]
2044 ;;; Call the emit function for TEMPLATE, linking the result in at the
2046 (defmacro emit-template
(node block template args results
&optional info
)
2047 `(emit-and-insert-vop ,node
,block
,template
,args
,results nil
2048 ,@(when info
`(,info
))))
2050 ;;; VOP Name Node Block Arg* Info* Result*
2052 ;;; Emit the VOP (or other template) NAME at the end of the IR2-BLOCK
2053 ;;; BLOCK, using NODE for the source context. The interpretation of
2054 ;;; the remaining arguments depends on the number of operands of
2055 ;;; various kinds that are declared in the template definition. VOP
2056 ;;; cannot be used for templates that have more-args or more-results,
2057 ;;; since the number of arguments and results is indeterminate for
2058 ;;; these templates. Use VOP* instead.
2060 ;;; ARGS and RESULTS are the TNs that are to be referenced by the
2061 ;;; template as arguments and results. If the template has
2062 ;;; codegen-info arguments, then the appropriate number of INFO forms
2063 ;;; following the arguments are used for codegen info.
2064 (defmacro vop
(name node block
&rest operands
)
2065 (let* ((parse (vop-parse-or-lose name
))
2066 (arg-count (length (vop-parse-args parse
)))
2067 (result-count (length (vop-parse-results parse
)))
2068 (info-count (- (length (vop-parse-info-args parse
))
2069 (if (vop-parse-gc-barrier parse
)
2072 (noperands (+ arg-count result-count info-count
))
2075 (n-template (gensym)))
2077 (when (or (vop-parse-more-args parse
) (vop-parse-more-results parse
))
2078 (error "cannot use VOP with variable operand count templates"))
2079 (unless (= noperands
(length operands
))
2080 (error "called with ~W operands, but was expecting ~W"
2081 (length operands
) noperands
))
2083 (multiple-value-bind (acode abinds n-args
)
2084 (make-operand-list (subseq operands
0 arg-count
) nil nil
)
2085 (multiple-value-bind (rcode rbinds n-results
)
2086 (make-operand-list (subseq operands
(+ arg-count info-count
)) nil t
)
2090 (dolist (info (subseq operands arg-count
(+ arg-count info-count
)))
2091 (let ((temp (gensym)))
2092 (ibinds `(,temp
,info
))
2095 `(let* ((,n-node
,node
)
2097 (,n-template
(template-or-lose ',name
))
2103 (emit-template ,n-node
,n-block
,n-template
,n-args
2106 `((list ,@(ivars)))))
2109 ;;; VOP* Name Node Block (Arg* More-Args) (Result* More-Results) Info*
2111 ;;; This is like VOP, but allows for emission of templates with
2112 ;;; arbitrary numbers of arguments, and for emission of templates
2113 ;;; using already-created TN-REF lists.
2115 ;;; The ARGS and RESULTS are TNs to be referenced as the first
2116 ;;; arguments and results to the template. More-Args and More-Results
2117 ;;; are heads of TN-REF lists that are added onto the end of the
2118 ;;; TN-REFS for the explicitly supplied operand TNs. The TN-REFS for
2119 ;;; the more operands must have the TN and WRITE-P slots correctly
2122 ;;; As with VOP, the INFO forms are evaluated and passed as codegen
2124 (defmacro vop
* (name node block args results
&rest info
)
2125 (declare (type cons args results
))
2126 (let* ((parse (vop-parse-or-lose name
))
2127 (arg-count (length (vop-parse-args parse
)))
2128 (result-count (length (vop-parse-results parse
)))
2129 (info-count (length (vop-parse-info-args parse
)))
2130 (fixed-args (butlast args
))
2131 (fixed-results (butlast results
))
2134 (n-template (gensym)))
2136 (unless (or (vop-parse-more-args parse
)
2137 (<= (length fixed-args
) arg-count
))
2138 (error "too many fixed arguments"))
2139 (unless (or (vop-parse-more-results parse
)
2140 (<= (length fixed-results
) result-count
))
2141 (error "too many fixed results"))
2142 (unless (= (length info
) info-count
)
2143 (error "expected ~W info args" info-count
))
2145 (multiple-value-bind (acode abinds n-args
)
2146 (make-operand-list fixed-args
(car (last args
)) nil
)
2147 (multiple-value-bind (rcode rbinds n-results
)
2148 (make-operand-list fixed-results
(car (last results
)) t
)
2150 `(let* ((,n-node
,node
)
2152 (,n-template
(template-or-lose ',name
))
2157 (emit-template ,n-node
,n-block
,n-template
,n-args
,n-results
2162 ;;;; miscellaneous macros
2164 ;;; SC-Case TN {({(SC-Name*) | SC-Name | T} Form*)}*
2166 ;;; Case off of TN's SC. The first clause containing TN's SC is
2167 ;;; evaluated, returning the values of the last form. A clause
2168 ;;; beginning with T specifies a default. If it appears, it must be
2169 ;;; last. If no default is specified, and no clause matches, then an
2170 ;;; error is signalled.
2171 (defmacro sc-case
(tn &body forms
)
2172 (let ((n-sc (gensym))
2174 (collect ((clauses))
2175 (do ((cases forms
(rest cases
)))
2177 (clauses `(t (locally (declare (optimize (safety 0))) ;; avoid NIL-FUN-RETURNED-ERROR
2178 (unknown-sc-case ,n-tn
)))))
2179 (let ((case (first cases
)))
2181 (error "illegal SC-CASE clause: ~S" case
))
2182 (let ((head (first case
)))
2185 (error "T case is not last in SC-CASE."))
2186 (clauses `(t nil
,@(rest case
)))
2188 (clauses `((or ,@(mapcar (lambda (x)
2189 `(eql ,(sc-number-or-lose x
) ,n-sc
))
2190 (if (atom head
) (list head
) head
)))
2191 nil
,@(rest case
))))))
2194 (,n-sc
(sc-number (tn-sc ,n-tn
))))
2195 (cond ,@(clauses))))))
2197 (defun unknown-sc-case (tn)
2198 (error "unknown SC to SC-CASE for ~S:~% ~S" tn
(sc-name (tn-sc tn
))))
2200 ;;; Return true if TNs SC is any of the named SCs, false otherwise.
2201 (defmacro sc-is
(tn &rest scs
)
2202 (once-only ((n-sc `(sc-number (tn-sc ,tn
))))
2203 `(or ,@(mapcar (lambda (x)
2204 `(eql ,n-sc
,(sc-number-or-lose x
)))
2207 ;;; Iterate over the IR2 blocks in component, in emission order.
2208 (defmacro do-ir2-blocks
((block-var component
&optional result
)
2210 `(do ((,block-var
(block-info (component-head ,component
))
2211 (ir2-block-next ,block-var
)))
2212 ((null ,block-var
) ,result
)
2215 ;;; Iterate over all the TNs live at some point, with the live set
2216 ;;; represented by a local conflicts bit-vector and the IR2-BLOCK
2217 ;;; containing the location.
2218 (defmacro do-live-tns
((tn-var live block
&optional result
) &body body
)
2219 (with-unique-names (conf bod i ltns
)
2220 (once-only ((n-live live
)
2223 (flet ((,bod
(,tn-var
) ,@body
))
2224 ;; Do component-live TNs.
2225 (dolist (,tn-var
(ir2-component-component-tns
2228 (ir2-block-block ,n-block
)))))
2231 (let ((,ltns
(ir2-block-local-tns ,n-block
)))
2232 ;; Do TNs always-live in this block and live :MORE TNs.
2233 (do ((,conf
(ir2-block-global-tns ,n-block
)
2234 (global-conflicts-next-blockwise ,conf
)))
2236 (when (or (eq (global-conflicts-kind ,conf
) :live
)
2237 (let ((,i
(global-conflicts-number ,conf
)))
2238 (and (eq (svref ,ltns
,i
) :more
)
2239 (not (zerop (sbit ,n-live
,i
))))))
2240 (,bod
(global-conflicts-tn ,conf
))))
2241 ;; Do TNs locally live in the designated live set.
2242 (dotimes (,i
(ir2-block-local-tn-count ,n-block
) ,result
)
2243 (unless (zerop (sbit ,n-live
,i
))
2244 (let ((,tn-var
(svref ,ltns
,i
)))
2245 (when (and ,tn-var
(not (eq ,tn-var
:more
)))
2246 (,bod
,tn-var
)))))))))))
2248 ;;; Iterate over all the IR2 blocks in the environment ENV, in emit
2250 (defmacro do-environment-ir2-blocks
((block-var env
&optional result
)
2252 (once-only ((n-env env
))
2253 (once-only ((n-first `(lambda-block (environment-lambda ,n-env
))))
2254 (once-only ((n-tail `(block-info
2256 (block-component ,n-first
)))))
2257 `(do ((,block-var
(block-info ,n-first
)
2258 (ir2-block-next ,block-var
)))
2259 ((or (eq ,block-var
,n-tail
)
2260 (not (eq (ir2-block-environment ,block-var
) ,n-env
)))
