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 ;;; Enter the basic structure at meta-compile time, and then fill in the
24 ;;; missing slots at load time.
25 (defmacro define-storage-base (name kind &key size)
27 "Define-Storage-Base Name Kind {Key Value}*
28 Define a storage base having the specified Name. Kind may be :Finite,
29 :Unbounded or :Non-Packed. The following keywords are legal:
32 Specify the number of locations in a :Finite SB or the initial size of a
35 ;; FIXME: Replace with DECLARE.
36 (check-type name symbol)
37 (check-type kind (member :finite :unbounded :non-packed))
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 (check-type size unsigned-byte)))
48 (let ((res (if (eq kind :non-packed)
49 (make-sb :name name :kind kind)
50 (make-finite-sb :name name :kind kind :size size))))
52 (eval-when (:compile-toplevel :load-toplevel :execute)
53 (/show0 "about to SETF GETHASH META-SB-NAMES in DEFINE-STORAGE-BASE")
54 (setf (gethash ',name *backend-meta-sb-names*)
56 (/show0 "about to SETF GETHASH SB-NAMES in DEFINE-STORAGE-BASE")
57 ,(if (eq kind :non-packed)
58 `(setf (gethash ',name *backend-sb-names*)
60 `(let ((res (copy-finite-sb ',res)))
61 (/show0 "not :NON-PACKED, i.e. hairy case")
62 (setf (finite-sb-always-live res)
65 #-(or sb-xc sb-xc-host) #*
66 ;; The cross-compiler isn't very good at
67 ;; dumping specialized arrays; we work around
68 ;; that by postponing generation of the
69 ;; specialized array 'til runtime.
70 #+(or sb-xc sb-xc-host)
71 (make-array 0 :element-type 'bit)))
72 (/show0 "doing second SETF")
73 (setf (finite-sb-conflicts res)
74 (make-array ',size :initial-element '#()))
75 (/show0 "doing third SETF")
76 (setf (finite-sb-live-tns res)
77 (make-array ',size :initial-element nil))
78 (/show0 "doing fourth 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 (defmacro define-storage-class (name number sb-name &key (element-size '1)
90 (alignment '1) locations reserve-locations
91 save-p alternate-scs constant-scs)
93 "Define-Storage-Class Name Number Storage-Base {Key Value}*
94 Define a storage class Name that uses the named Storage-Base. Number is a
95 small, non-negative integer that is used as an alias. The following
99 The size of objects in this SC in whatever units the SB uses. This
103 The alignment restrictions for this SC. TNs will only be allocated at
104 offsets that are an even multiple of this number. Defaults to 1.
106 :Locations (Location*)
107 If the SB is :Finite, then this is a list of the offsets within the SB
110 :Reserve-Locations (Location*)
111 A subset of the Locations that the register allocator should try to
112 reserve for operand loading (instead of to hold variable values.)
115 If T, then values stored in this SC must be saved in one of the
116 non-save-p :Alternate-SCs across calls.
119 Indicates other SCs that can be used to hold values from this SC across
120 calls or when storage in this SC is exhausted. The SCs should be
121 specified in order of decreasing \"goodness\". There must be at least
122 one SC in an unbounded SB, unless this SC is only used for restricted or
126 A list of the names of all the constant SCs that can be loaded into this
127 SC by a move function."
129 (check-type name symbol)
130 (check-type number sc-number)
131 (check-type sb-name symbol)
132 (check-type locations list)
133 (check-type reserve-locations list)
134 (check-type save-p boolean)
135 (check-type alternate-scs list)
136 (check-type constant-scs list)
137 (unless (= (logcount alignment) 1)
138 (error "alignment not a power of two: ~D" alignment))
140 (let ((sb (meta-sb-or-lose sb-name)))
141 (if (eq (sb-kind sb) :finite)
142 (let ((size (sb-size sb))
143 (element-size (eval element-size)))
144 (check-type element-size unsigned-byte)
145 (dolist (el locations)
146 (check-type el unsigned-byte)
147 (unless (<= 1 (+ el element-size) size)
148 (error "SC element ~D out of bounds for ~S" el sb))))
150 (error ":LOCATIONS is meaningless in a ~S SB." (sb-kind sb))))
152 (unless (subsetp reserve-locations locations)
153 (error "RESERVE-LOCATIONS not a subset of LOCATIONS."))
155 (when (and (or alternate-scs constant-scs)
156 (eq (sb-kind sb) :non-packed))
158 "It's meaningless to specify alternate or constant SCs in a ~S SB."
162 (if (or (eq sb-name 'non-descriptor-stack)
163 (find 'non-descriptor-stack
164 (mapcar #'meta-sc-or-lose alternate-scs)
166 (sb-name (sc-sb x)))))
169 (eval-when (:compile-toplevel :load-toplevel :execute)
170 (let ((res (make-sc :name ',name :number ',number
171 :sb (meta-sb-or-lose ',sb-name)
172 :element-size ,element-size
173 :alignment ,alignment
174 :locations ',locations
175 :reserve-locations ',reserve-locations
177 :number-stack-p ,nstack-p
178 :alternate-scs (mapcar #'meta-sc-or-lose
180 :constant-scs (mapcar #'meta-sc-or-lose
182 (setf (gethash ',name *backend-meta-sc-names*) res)
183 (setf (svref *backend-meta-sc-numbers* ',number) res)
184 (setf (svref (sc-load-costs res) ',number) 0)))
186 (let ((old (svref *backend-sc-numbers* ',number)))
187 (when (and old (not (eq (sc-name old) ',name)))
188 (warn "redefining SC number ~D from ~S to ~S" ',number
189 (sc-name old) ',name)))
191 (setf (svref *backend-sc-numbers* ',number)
192 (meta-sc-or-lose ',name))
193 (setf (gethash ',name *backend-sc-names*)
194 (meta-sc-or-lose ',name))
195 (setf (sc-sb (sc-or-lose ',name)) (sb-or-lose ',sb-name))
198 ;;;; move/coerce definition
200 ;;; Given a list of pairs of lists of SCs (as given to DEFINE-MOVE-VOP,
201 ;;; etc.), bind TO-SC and FROM-SC to all the combinations.
202 (defmacro do-sc-pairs ((from-sc-var to-sc-var scs) &body body)
203 `(do ((froms ,scs (cddr froms))
204 (tos (cdr ,scs) (cddr tos)))
206 (dolist (from (car froms))
207 (let ((,from-sc-var (meta-sc-or-lose from)))
208 (dolist (to (car tos))
209 (let ((,to-sc-var (meta-sc-or-lose to)))
212 (defmacro define-move-function ((name cost) lambda-list scs &body body)
214 "Define-Move-Function (Name Cost) lambda-list ({(From-SC*) (To-SC*)}*) form*
215 Define the function Name and note it as the function used for moving operands
216 from the From-SCs to the To-SCs. Cost is the cost of this move operation.
217 The function is called with three arguments: the VOP (for context), and the
218 source and destination TNs. An ASSEMBLE form is wrapped around the body.
219 All uses of DEFINE-MOVE-FUNCTION should be compiled before any uses of
221 (when (or (oddp (length scs)) (null scs))
222 (error "malformed SCs spec: ~S" scs))
223 (check-type cost index)
225 (eval-when (:compile-toplevel :load-toplevel :execute)
226 (do-sc-pairs (from-sc to-sc ',scs)
227 (unless (eq from-sc to-sc)
228 (let ((num (sc-number from-sc)))
229 (setf (svref (sc-move-functions to-sc) num) ',name)
230 (setf (svref (sc-load-costs to-sc) num) ',cost)))))
232 (defun ,name ,lambda-list
233 (sb!assem:assemble (*code-segment* ,(first lambda-list))
236 (eval-when (:compile-toplevel :load-toplevel :execute)
237 (defparameter *sc-vop-slots*
238 '((:move . sc-move-vops)
239 (:move-argument . sc-move-arg-vops))))
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)
245 "Define-Move-VOP Name {:Move | :Move-Argument} {(From-SC*) (To-SC*)}*
246 Make Name be the VOP used to move values in the specified From-SCs to the
247 representation of the To-SCs. If kind is :Move-Argument, then the VOP takes
248 an extra argument, which is the frame pointer of the frame to move into."
249 (when (or (oddp (length scs)) (null scs))
250 (error "malformed SCs spec: ~S" scs))
251 (let ((accessor (or (cdr (assoc kind *sc-vop-slots*))
252 (error "unknown kind ~S" kind))))
254 ,@(when (eq kind :move)
255 `((eval-when (:compile-toplevel :load-toplevel :execute)
256 (do-sc-pairs (from-sc to-sc ',scs)
257 (compute-move-costs from-sc to-sc
259 (vop-parse-or-lose name)))))))
261 (let ((vop (template-or-lose ',name)))
262 (do-sc-pairs (from-sc to-sc ',scs)
263 (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc)))
264 (let ((vec (,accessor dest-sc)))
265 (let ((scn (sc-number from-sc)))
266 (setf (svref vec scn)
267 (adjoin-template vop (svref vec scn))))
268 (dolist (sc (append (sc-alternate-scs from-sc)
269 (sc-constant-scs from-sc)))
270 (let ((scn (sc-number sc)))
271 (setf (svref vec scn)
272 (adjoin-template vop (svref vec scn))))))))))))
274 ;;;; primitive type definition
276 (defun meta-primitive-type-or-lose (name)
278 (or (gethash name *backend-meta-primitive-type-names*)
279 (error "~S is not a defined primitive type." name))))
281 ;;; If the primitive-type structure already exists, we destructively modify
282 ;;; it so that existing references in templates won't be invalidated.
283 (defmacro def-primitive-type (name scs &key (type name))
285 "Def-Primitive-Type Name (SC*) {Key Value}*
286 Define a primitive type Name. Each SC specifies a Storage Class that values
287 of this type may be allocated in. The following keyword options are
291 The type descriptor for the Lisp type that is equivalent to this type
293 (check-type name symbol)
294 (check-type scs list)
295 (let ((scns (mapcar #'meta-sc-number-or-lose scs))
296 (get-type `(specifier-type ',type)))
298 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
299 (setf (gethash ',name *backend-meta-primitive-type-names*)
300 (make-primitive-type :name ',name
303 ,(once-only ((n-old `(gethash ',name *backend-primitive-type-names*))
307 (setf (primitive-type-scs ,n-old) ',scns)
308 (setf (primitive-type-type ,n-old) ,n-type))
310 (setf (gethash ',name *backend-primitive-type-names*)
311 (make-primitive-type :name ',name
316 ;;; Just record the translation.
317 (defmacro def-primitive-type-alias (name result)
319 "DEF-PRIMITIVE-TYPE-ALIAS Name Result
320 Define name to be an alias for Result in VOP operand type restrictions."
321 `(eval-when (:compile-toplevel :load-toplevel :execute)
322 (setf (gethash ',name *backend-primitive-type-aliases*) ',result)
325 (defparameter *primitive-type-slot-alist*
326 '((:check . primitive-type-check)))
328 (defmacro primitive-type-vop (vop kinds &rest types)
330 "Primitive-Type-VOP Vop (Kind*) Type*
331 Annotate all the specified primitive Types with the named VOP under each of
335 A one argument one result VOP that moves the argument to the result,
336 checking that the value is of this type in the process."
337 (let ((n-vop (gensym))
339 `(let ((,n-vop (template-or-lose ',vop)))
342 `(let ((,n-type (primitive-type-or-lose ',type)))
345 (let ((slot (or (cdr (assoc kind
346 *primitive-type-slot-alist*))
347 (error "unknown kind: ~S" kind))))
348 `(setf (,slot ,n-type) ,n-vop)))
353 ;;; Return true if SC is either one of Ptype's SC's, or one of those SC's
354 ;;; alternate or constant SCs.
355 (defun meta-sc-allowed-by-primitive-type (sc ptype)
356 (declare (type sc sc) (type primitive-type ptype))
357 (let ((scn (sc-number sc)))
358 (dolist (allowed (primitive-type-scs ptype) nil)
359 (when (eql allowed scn)
361 (let ((allowed-sc (svref *backend-meta-sc-numbers* allowed)))
362 (when (or (member sc (sc-alternate-scs allowed-sc))
363 (member sc (sc-constant-scs allowed-sc)))
366 ;;;; VOP definition structures
368 ;;;; Define-VOP uses some fairly complex data structures at meta-compile
369 ;;;; time, both to hold the results of parsing the elaborate syntax and to
370 ;;;; retain the information so that it can be inherited by other VOPs.
372 ;;; The VOP-Parse structure holds everything we need to know about a VOP at
373 ;;; meta-compile time.
374 (def!struct (vop-parse
375 (:make-load-form-fun just-dump-it-normally)
376 #-sb-xc-host (:pure t))
377 ;; The name of this VOP.
378 (name nil :type symbol)
379 ;; If true, then the name of the VOP we inherit from.
380 (inherits nil :type (or symbol null))
381 ;; Lists of Operand-Parse structures describing the arguments, results and
382 ;; temporaries of the VOP.
383 (args nil :type list)
384 (results nil :type list)
385 (temps nil :type list)
386 ;; Operand-Parse structures containing information about more args and
387 ;; results. If null, then there there are no more operands of that kind.
388 (more-args nil :type (or operand-parse null))
389 (more-results nil :type (or operand-parse null))
390 ;; A list of all the above together.
391 (operands nil :type list)
392 ;; Names of variables that should be declared ignore.
393 (ignores () :type list)
394 ;; True if this is a :Conditional VOP.
396 ;; Argument and result primitive types. These are pulled out of the
397 ;; operands, since we often want to change them without respecifying the
399 (arg-types :unspecified :type (or (member :unspecified) list))
400 (result-types :unspecified :type (or (member :unspecified) list))
401 ;; The guard expression specified, or NIL if none.
403 ;; The cost of and body code for the generator.
404 (cost 0 :type unsigned-byte)
405 (body :unspecified :type (or (member :unspecified) list))
406 ;; Info for VOP variants. The list of forms to be evaluated to get the
407 ;; variant args for this VOP, and the list of variables to be bound to the
409 (variant () :type list)
410 (variant-vars () :type list)
411 ;; Variables bound to the VOP and Vop-Node when in the generator body.
412 (vop-var (gensym) :type symbol)
413 (node-var nil :type (or symbol null))
414 ;; A list of the names of the codegen-info arguments to this VOP.
415 (info-args () :type list)
416 ;; An efficiency note associated with this VOP.
417 (note nil :type (or string null))
418 ;; A list of the names of the Effects and Affected attributes for this VOP.
419 (effects '(any) :type list)
420 (affected '(any) :type list)
421 ;; A list of the names of functions this VOP is a translation of and the
422 ;; policy that allows this translation to be done. :Fast is a safe default,
423 ;; since it isn't a safe policy.
424 (translate () :type list)
425 (policy :fast :type policies)
426 ;; Stuff used by life analysis.
427 (save-p nil :type (member t nil :compute-only :force-to-stack))
428 ;; Info about how to emit move-argument VOPs for the more operand in
430 (move-args nil :type (member nil :local-call :full-call :known-return)))
432 (defprinter (vop-parse)
434 (inherits :test inherits)
438 (more-args :test more-args)
439 (more-results :test more-results)
440 (conditional-p :test conditional-p)
446 (variant :test variant)
447 (variant-vars :test variant-vars)
448 (info-args :test info-args)
454 (save-p :test save-p)
455 (move-args :test move-args))
457 ;;; An OPERAND-PARSE object contains stuff we need to know about an operand or
458 ;;; temporary at meta-compile time. Besides the obvious stuff, we also store
459 ;;; the names of per-operand temporaries here.
460 (def!struct (operand-parse
461 (:make-load-form-fun just-dump-it-normally)
462 #-sb-xc-host (:pure t))
463 ;; Name of the operand (which we bind to the TN).
464 (name nil :type symbol)
465 ;; The way this operand is used:
466 (kind (required-argument)
467 :type (member :argument :result :temporary
468 :more-argument :more-result))
469 ;; If true, the name of an operand that this operand is targeted to. This is
470 ;; only meaningful in :Argument and :Temporary operands.
471 (target nil :type (or symbol null))
472 ;; Temporary that holds the TN-Ref for this operand. Temp-Temp holds the
473 ;; write reference that begins a temporary's lifetime.
474 (temp (gensym) :type symbol)
475 (temp-temp nil :type (or symbol null))
476 ;; The time that this operand is first live and the time at which it becomes
477 ;; dead again. These are time-specs, as returned by parse-time-spec.
480 ;; A list of the names of the SCs that this operand is allowed into. If
481 ;; false, there is no restriction.
483 ;; Variable that is bound to the load TN allocated for this operand, or to
484 ;; NIL if no load-TN was allocated.
485 (load-tn (gensym) :type symbol)
486 ;; An expression that tests whether to do automatic operand loading.
488 ;; In a wired or restricted temporary this is the SC the TN is to be packed
489 ;; in. Null otherwise.
490 (sc nil :type (or symbol null))
491 ;; If non-null, we are a temp wired to this offset in SC.
492 (offset nil :type (or unsigned-byte null)))
494 (defprinter (operand-parse)
497 (target :test target)
503 (offset :test offset))
505 ;;;; miscellaneous utilities
507 ;;; Find the operand or temporary with the specifed Name in the VOP Parse.
508 ;;; If there is no such operand, signal an error. Also error if the operand
509 ;;; kind isn't one of the specified Kinds. If Error-P is NIL, just return NIL
510 ;;; if there is no such operand.
511 (defun find-operand (name parse &optional
512 (kinds '(:argument :result :temporary))
514 (declare (symbol name) (type vop-parse parse) (list kinds))
515 (let ((found (find name (vop-parse-operands parse)
516 :key #'operand-parse-name)))
518 (unless (member (operand-parse-kind found) kinds)
519 (error "Operand ~S isn't one of these kinds: ~S." name kinds))
521 (error "~S is not an operand to ~S." name (vop-parse-name parse))))
524 ;;; Get the VOP-Parse structure for NAME or die trying. For all
525 ;;; meta-compile time uses, the VOP-Parse should be used instead of the
527 (defun vop-parse-or-lose (name)
529 (or (gethash name *backend-parsed-vops*)
530 (error "~S is not the name of a defined VOP." name))))
532 ;;; Return a list of let-forms to parse a tn-ref list into a the temps
533 ;;; specified by the operand-parse structures. More-Operand is the
534 ;;; Operand-Parse describing any more operand, or NIL if none. Refs is an
535 ;;; expression that evaluates into the first tn-ref.
536 (defun access-operands (operands more-operand refs)
537 (declare (list operands))
540 (dolist (op operands)
541 (let ((n-ref (operand-parse-temp op)))
542 (res `(,n-ref ,prev))
543 (setq prev `(tn-ref-across ,n-ref))))
546 (res `(,(operand-parse-name more-operand) ,prev))))
549 ;;; Used with Access-Operands to prevent warnings for TN-Ref temps not used
550 ;;; by some particular function. It returns the name of the last operand, or
551 ;;; NIL if Operands is NIL.
552 (defun ignore-unreferenced-temps (operands)
554 (operand-parse-temp (car (last operands)))))
556 ;;; Grab an arg out of a VOP spec, checking the type and syntax and stuff.
557 (defun vop-spec-arg (spec type &optional (n 1) (last t))
558 (let ((len (length spec)))
560 (error "~:R argument missing: ~S" n spec))
561 (when (and last (> len (1+ n)))
562 (error "extra junk at end of ~S" spec))
563 (let ((thing (elt spec n)))
564 (unless (typep thing type)
565 (error "~:R argument is not a ~S: ~S" n type spec))
570 ;;; Return a time spec describing a time during the evaluation of a VOP,
571 ;;; used to delimit operand and temporary lifetimes. The representation is a
572 ;;; cons whose CAR is the number of the evaluation phase and the CDR is the
573 ;;; sub-phase. The sub-phase is 0 in the :Load and :Save phases.
574 (defun parse-time-spec (spec)
575 (let ((dspec (if (atom spec) (list spec 0) spec)))
576 (unless (and (= (length dspec) 2)
577 (typep (second dspec) 'unsigned-byte))
578 (error "malformed time specifier: ~S" spec))
580 (cons (case (first dspec)
587 (error "unknown phase in time specifier: ~S" spec)))
590 ;;; Return true if the time spec X is the same or later time than Y.
591 (defun time-spec-order (x y)
592 (or (> (car x) (car y))
593 (and (= (car x) (car y))
594 (>= (cdr x) (cdr y)))))
596 ;;;; generation of emit functions
598 (defun compute-temporaries-description (parse)
599 (let ((temps (vop-parse-temps parse))
600 (element-type '(unsigned-byte 16)))
602 (let ((results (make-specializable-array
604 :element-type element-type))
607 (declare (type operand-parse temp))
608 (let ((sc (operand-parse-sc temp))
609 (offset (operand-parse-offset temp)))
611 (setf (aref results index)
613 (+ (ash offset (1+ sc-bits))
614 (ash (meta-sc-number-or-lose sc) 1)
616 (ash (meta-sc-number-or-lose sc) 1))))
618 ;; KLUDGE: As in the other COERCEs wrapped around with
619 ;; MAKE-SPECIALIZABLE-ARRAY results in COMPUTE-REF-ORDERING, this
620 ;; coercion could be removed by a sufficiently smart compiler, but I
621 ;; dunno whether Python is that smart. It would be good to check this
622 ;; and help it if it's not smart enough to remove it for itself.
623 ;; However, it's probably not urgent, since the overhead of an extra
624 ;; no-op conversion is unlikely to be large compared to consing and
625 ;; corresponding GC. -- WHN ca. 19990701
626 `(coerce ,results '(specializable-vector ,element-type))))))
628 (defun compute-ref-ordering (parse)
629 (let* ((num-args (+ (length (vop-parse-args parse))
630 (if (vop-parse-more-args parse) 1 0)))
631 (num-results (+ (length (vop-parse-results parse))
632 (if (vop-parse-more-results parse) 1 0)))
634 (collect ((refs) (targets))
635 (dolist (op (vop-parse-operands parse))
636 (when (operand-parse-target op)
637 (unless (member (operand-parse-kind op) '(:argument :temporary))
638 (error "cannot target a ~S operand: ~S" (operand-parse-kind op)
639 (operand-parse-name op)))
640 (let ((target (find-operand (operand-parse-target op) parse
641 '(:temporary :result))))
642 (targets (+ (* index max-vop-tn-refs)
643 (ecase (operand-parse-kind target)
645 (+ (position-or-lose target
646 (vop-parse-results parse))
649 (+ (* (position-or-lose target
650 (vop-parse-temps parse))
652 num-args num-results)))))))
653 (let ((born (operand-parse-born op))
654 (dies (operand-parse-dies op)))
655 (ecase (operand-parse-kind op)
657 (refs (cons (cons dies nil) index)))
659 (refs (cons (cons dies nil) index)))
661 (refs (cons (cons born t) index)))
663 (refs (cons (cons born t) index)))
665 (refs (cons (cons dies nil) index))
667 (refs (cons (cons born t) index))))
669 (let* ((sorted (sort (refs)
671 (let ((x-time (car x))
673 (if (time-spec-order x-time y-time)
674 (if (time-spec-order y-time x-time)
675 (and (not (cdr x)) (cdr y))
679 (oe-type '(mod #.max-vop-tn-refs)) ; :REF-ORDERING element type
680 (te-type '(mod #.(* max-vop-tn-refs 2))) ; :TARGETS element type
681 (ordering (make-specializable-array
683 :element-type oe-type)))
686 (setf (aref ordering index) (cdr ref))
688 `(:num-args ,num-args
689 :num-results ,num-results
690 ;; KLUDGE: The (COERCE .. (SPECIALIZABLE-VECTOR ..)) wrapper here
691 ;; around the result returned by MAKE-SPECIALIZABLE-ARRAY above was
692 ;; of course added to help with cross-compilation. "A sufficiently
693 ;; smart compiler" should be able to optimize all this away in the
694 ;; final target Lisp, leaving a single MAKE-ARRAY with no subsequent
695 ;; coercion. However, I don't know whether Python is that smart. (Can
696 ;; it figure out the return type of MAKE-ARRAY? Does it know that
697 ;; COERCE can be optimized away if the input type is known to be the
698 ;; same as the COERCEd-to type?) At some point it would be good to
699 ;; test to see whether this construct is in fact causing run-time
700 ;; overhead, and fix it if so. (Some declarations of the types
701 ;; returned by MAKE-ARRAY might be enough to fix it.) However, it's
702 ;; probably not urgent to fix this, since it's hard to imagine that
703 ;; any overhead caused by calling COERCE and letting it decide to
704 ;; bail out could be large compared to the cost of consing and GCing
705 ;; the vectors in the first place. -- WHN ca. 19990701
706 :ref-ordering (coerce ',ordering
707 '(specializable-vector ,oe-type))
709 `(:targets (coerce ',(targets)
710 '(specializable-vector ,te-type)))))))))
712 (defun make-emit-function-and-friends (parse)
713 `(:emit-function #'emit-generic-vop
714 :temps ,(compute-temporaries-description parse)
715 ,@(compute-ref-ordering parse)))
717 ;;;; generator functions
719 ;;; Return an alist that translates from lists of SCs we can load OP from to
720 ;;; the move function used for loading those SCs. We quietly ignore
721 ;;; restrictions to :non-packed (constant) and :unbounded SCs, since we don't
722 ;;; load into those SCs.
723 (defun find-move-functions (op load-p)
725 (dolist (sc-name (operand-parse-scs op))
726 (let* ((sc (meta-sc-or-lose sc-name))
728 (load-scs (append (when load-p
729 (sc-constant-scs sc))
730 (sc-alternate-scs sc))))
733 (dolist (alt load-scs)
734 (unless (member (sc-name alt) (operand-parse-scs op) :test #'eq)
735 (let* ((altn (sc-number alt))
737 (svref (sc-move-functions sc) altn)
738 (svref (sc-move-functions alt) scn)))
739 (found (or (assoc alt (funs) :test #'member)
740 (rassoc name (funs)))))
742 (error "no move function defined to ~:[save~;load~] SC ~S ~
743 with ~S ~:[to~;from~] from SC ~S"
744 load-p sc-name load-p (sc-name alt)))
747 (unless (eq (cdr found) name)
748 (error "can't tell whether to ~:[save~;load~]~@
749 or ~S when operand is in SC ~S"
750 load-p name (cdr found) (sc-name alt)))
751 (pushnew alt (car found)))
753 (funs (cons (list alt) name))))))))
754 ((member (sb-kind (sc-sb sc)) '(:non-packed :unbounded)))
756 (error "SC ~S has no alternate~:[~; or constant~] SCs, yet it is~@
757 mentioned in the restriction for operand ~S"
758 sc-name load-p (operand-parse-name op))))))
761 ;;; Return a form to load/save the specified operand when it has a load TN.
762 ;;; For any given SC that we can load from, there must be a unique load
763 ;;; function. If all SCs we can load from have the same move function, then we
764 ;;; just call that when there is a load TN. If there are multiple possible
765 ;;; move functions, then we dispatch off of the operand TN's type to see which
766 ;;; move function to use.
767 (defun call-move-function (parse op load-p)
768 (let ((funs (find-move-functions op load-p))
769 (load-tn (operand-parse-load-tn op)))
771 (let* ((tn `(tn-ref-tn ,(operand-parse-temp op)))
772 (n-vop (or (vop-parse-vop-var parse)
773 (setf (vop-parse-vop-var parse) (gensym))))
774 (form (if (rest funs)
776 ,@(mapcar #'(lambda (x)
777 `(,(mapcar #'sc-name (car x))
779 `(,(cdr x) ,n-vop ,tn
781 `(,(cdr x) ,n-vop ,load-tn
785 `(,(cdr (first funs)) ,n-vop ,tn ,load-tn)
786 `(,(cdr (first funs)) ,n-vop ,load-tn ,tn)))))
787 (if (eq (operand-parse-load op) t)
788 `(when ,load-tn ,form)
789 `(when (eq ,load-tn ,(operand-parse-name op))
792 (error "load TN allocated, but no move function?~@
793 VM definition is inconsistent, recompile and try again.")))))
795 ;;; Return the TN that we should bind to the operand's var in the generator
796 ;;; body. In general, this involves evaluating the :LOAD-IF test expression.
797 (defun decide-to-load (parse op)
798 (let ((load (operand-parse-load op))
799 (load-tn (operand-parse-load-tn op))
800 (temp (operand-parse-temp op)))
802 `(or ,load-tn (tn-ref-tn ,temp))
805 (dolist (x (vop-parse-operands parse))
806 (when (member (operand-parse-kind x) '(:argument :result))
807 (let ((name (operand-parse-name x)))
808 (binds `(,name (tn-ref-tn ,(operand-parse-temp x))))
812 (declare (ignorable ,@(ignores)))
815 (tn-ref-tn ,temp))))))
817 ;;; Make a lambda that parses the VOP TN-Refs, does automatic operand
818 ;;; loading, and runs the appropriate code generator.
819 (defun make-generator-function (parse)
820 (declare (type vop-parse parse))
821 (let ((n-vop (vop-parse-vop-var parse))
822 (operands (vop-parse-operands parse))
823 (n-info (gensym)) (n-variant (gensym)))
827 (dolist (op operands)
828 (ecase (operand-parse-kind op)
830 (let ((temp (operand-parse-temp op))
831 (name (operand-parse-name op)))
832 (cond ((and (operand-parse-load op) (operand-parse-scs op))
833 (binds `(,(operand-parse-load-tn op)
834 (tn-ref-load-tn ,temp)))
835 (binds `(,name ,(decide-to-load parse op)))
836 (if (eq (operand-parse-kind op) :argument)
837 (loads (call-move-function parse op t))
838 (saves (call-move-function parse op nil))))
840 (binds `(,name (tn-ref-tn ,temp)))))))
842 (binds `(,(operand-parse-name op)
843 (tn-ref-tn ,(operand-parse-temp op)))))
844 ((:more-argument :more-result))))
847 (let* (,@(access-operands (vop-parse-args parse)
848 (vop-parse-more-args parse)
850 ,@(access-operands (vop-parse-results parse)
851 (vop-parse-more-results parse)
852 `(vop-results ,n-vop))
853 ,@(access-operands (vop-parse-temps parse) nil
855 ,@(when (vop-parse-info-args parse)
856 `((,n-info (vop-codegen-info ,n-vop))
857 ,@(mapcar #'(lambda (x) `(,x (pop ,n-info)))
858 (vop-parse-info-args parse))))
859 ,@(when (vop-parse-variant-vars parse)
860 `((,n-variant (vop-info-variant (vop-info ,n-vop)))
861 ,@(mapcar #'(lambda (x) `(,x (pop ,n-variant)))
862 (vop-parse-variant-vars parse))))
863 ,@(when (vop-parse-node-var parse)
864 `((,(vop-parse-node-var parse) (vop-node ,n-vop))))
866 (declare (ignore ,@(vop-parse-ignores parse)))
868 (sb!assem:assemble (*code-segment* ,n-vop)
869 ,@(vop-parse-body parse))
872 ;;; Given a list of operand specifications as given to Define-VOP, return a
873 ;;; list of Operand-Parse structures describing the fixed operands, and a
874 ;;; single Operand-Parse describing any more operand. If we are inheriting a
875 ;;; VOP, we default attributes to the inherited operand of the same name.
876 (defun parse-operands (parse specs kind)
877 (declare (list specs)
878 (type (member :argument :result) kind))
881 (collect ((operands))
883 (unless (and (consp spec) (symbolp (first spec)) (oddp (length spec)))
884 (error "malformed operand specifier: ~S" spec))
886 (error "The MORE operand isn't the last operand: ~S" specs))
887 (let* ((name (first spec))
888 (old (if (vop-parse-inherits parse)
891 (vop-parse-inherits parse))
899 :target (operand-parse-target old)
900 :born (operand-parse-born old)
901 :dies (operand-parse-dies old)
902 :scs (operand-parse-scs old)
903 :load-tn (operand-parse-load-tn old)
904 :load (operand-parse-load old))
910 :born (parse-time-spec :load)
911 :dies (parse-time-spec `(:argument ,(incf num)))))
916 :born (parse-time-spec `(:result ,(incf num)))
917 :dies (parse-time-spec :save)))))))
918 (do ((key (rest spec) (cddr key)))
920 (let ((value (second key)))
923 (check-type value list)
924 (setf (operand-parse-scs res) (remove-duplicates value)))
926 (check-type value symbol)
927 (setf (operand-parse-load-tn res) value))
929 (setf (operand-parse-load res) value))
931 (check-type value boolean)
932 (setf (operand-parse-kind res)
933 (if (eq kind :argument) :more-argument :more-result))
934 (setf (operand-parse-load res) nil)
937 (check-type value symbol)
938 (setf (operand-parse-target res) value))
940 (unless (eq kind :result)
941 (error "can only specify :FROM in a result: ~S" spec))
942 (setf (operand-parse-born res) (parse-time-spec value)))
944 (unless (eq kind :argument)
945 (error "can only specify :TO in an argument: ~S" spec))
946 (setf (operand-parse-dies res) (parse-time-spec value)))
948 (error "unknown keyword in operand specifier: ~S" spec)))))
952 ((operand-parse-target more)
953 (error "cannot specify :TARGET in a :MORE operand"))
954 ((operand-parse-load more)
955 (error "cannot specify :LOAD-IF in a :MORE operand")))))
956 (values (the list (operands)) more))))
958 ;;; Parse a temporary specification, entering the Operand-Parse structures
959 ;;; in the Parse structure.
960 (defun parse-temporary (spec parse)
962 (type vop-parse parse))
963 (let ((len (length spec)))
965 (error "malformed temporary spec: ~S" spec))
966 (unless (listp (second spec))
967 (error "malformed options list: ~S" (second spec)))
968 (unless (evenp (length (second spec)))
969 (error "odd number of arguments in keyword options: ~S" spec))
970 (unless (consp (cddr spec))
971 (warn "temporary spec allocates no temps:~% ~S" spec))
972 (dolist (name (cddr spec))
973 (unless (symbolp name)
974 (error "bad temporary name: ~S" name))
975 (let ((res (make-operand-parse :name name
978 :born (parse-time-spec :load)
979 :dies (parse-time-spec :save))))
980 (do ((opt (second spec) (cddr opt)))
984 (setf (operand-parse-target res)
985 (vop-spec-arg opt 'symbol 1 nil)))
987 (setf (operand-parse-sc res)
988 (vop-spec-arg opt 'symbol 1 nil)))
990 (let ((offset (eval (second opt))))
991 (check-type offset unsigned-byte)
992 (setf (operand-parse-offset res) offset)))
994 (setf (operand-parse-born res) (parse-time-spec (second opt))))
996 (setf (operand-parse-dies res) (parse-time-spec (second opt))))
997 ;; Backward compatibility...
999 (let ((scs (vop-spec-arg opt 'list 1 nil)))
1000 (unless (= (length scs) 1)
1001 (error "must specify exactly one SC for a temporary"))
1002 (setf (operand-parse-sc res) (first scs))))
1005 (error "unknown temporary option: ~S" opt))))
1007 (unless (and (time-spec-order (operand-parse-dies res)
1008 (operand-parse-born res))
1009 (not (time-spec-order (operand-parse-born res)
1010 (operand-parse-dies res))))
1011 (error "Temporary lifetime doesn't begin before it ends: ~S" spec))
1013 (unless (operand-parse-sc res)
1014 (error "must specify :SC for all temporaries: ~S" spec))
1016 (setf (vop-parse-temps parse)
1018 (remove name (vop-parse-temps parse)
1019 :key #'operand-parse-name))))))
1022 ;;; Top-level parse function. Clobber Parse to represent the specified options.
1023 (defun parse-define-vop (parse specs)
1024 (declare (type vop-parse parse) (list specs))
1025 (dolist (spec specs)
1026 (unless (consp spec)
1027 (error "malformed option specification: ~S" spec))
1030 (multiple-value-bind (fixed more)
1031 (parse-operands parse (rest spec) :argument)
1032 (setf (vop-parse-args parse) fixed)
1033 (setf (vop-parse-more-args parse) more)))
1035 (multiple-value-bind (fixed more)
1036 (parse-operands parse (rest spec) :result)
1037 (setf (vop-parse-results parse) fixed)
1038 (setf (vop-parse-more-results parse) more))
1039 (setf (vop-parse-conditional-p parse) nil))
1041 (setf (vop-parse-result-types parse) ())
1042 (setf (vop-parse-results parse) ())
1043 (setf (vop-parse-more-results parse) nil)
1044 (setf (vop-parse-conditional-p parse) t))
1046 (parse-temporary spec parse))
1048 (setf (vop-parse-cost parse)
1049 (vop-spec-arg spec 'unsigned-byte 1 nil))
1050 (setf (vop-parse-body parse) (cddr spec)))
1052 (setf (vop-parse-effects parse) (rest spec)))
1054 (setf (vop-parse-affected parse) (rest spec)))
1056 (setf (vop-parse-info-args parse) (rest spec)))
1058 (setf (vop-parse-ignores parse) (rest spec)))
1060 (setf (vop-parse-variant parse) (rest spec)))
1062 (let ((vars (rest spec)))
1063 (setf (vop-parse-variant-vars parse) vars)
1064 (setf (vop-parse-variant parse)
1065 (make-list (length vars) :initial-element nil))))
1067 (setf (vop-parse-cost parse) (vop-spec-arg spec 'unsigned-byte)))
1069 (setf (vop-parse-vop-var parse) (vop-spec-arg spec 'symbol)))
1071 (setf (vop-parse-move-args parse)
1072 (vop-spec-arg spec '(member nil :local-call :full-call
1075 (setf (vop-parse-node-var parse) (vop-spec-arg spec 'symbol)))
1077 (setf (vop-parse-note parse) (vop-spec-arg spec '(or string null))))
1079 (setf (vop-parse-arg-types parse)
1080 (parse-operand-types (rest spec) t)))
1082 (setf (vop-parse-result-types parse)
1083 (parse-operand-types (rest spec) nil)))
1085 (setf (vop-parse-translate parse) (rest spec)))
1087 (setf (vop-parse-guard parse) (vop-spec-arg spec t)))
1089 (setf (vop-parse-policy parse) (vop-spec-arg spec 'policies)))
1091 (setf (vop-parse-save-p parse)
1093 '(member t nil :compute-only :force-to-stack))))
1095 (error "unknown option specifier: ~S" (first spec)))))
1098 ;;;; make costs and restrictions
1100 ;;; Given an operand, returns two values:
1101 ;;; 1. A SC-vector of the cost for the operand being in that SC, including both
1102 ;;; the costs for move functions and coercion VOPs.
1103 ;;; 2. A SC-vector holding the SC that we load into, for any SC that we can
1104 ;;; directly load from.
1106 ;;; In both vectors, unused entries are NIL. Load-P specifies the direction:
1107 ;;; if true, we are loading, if false we are saving.
1108 (defun compute-loading-costs (op load-p)
1109 (declare (type operand-parse op))
1110 (let ((scs (operand-parse-scs op))
1111 (costs (make-array sc-number-limit :initial-element nil))
1112 (load-scs (make-array sc-number-limit :initial-element nil)))
1113 (dolist (sc-name scs)
1114 (let* ((load-sc (meta-sc-or-lose sc-name))
1115 (load-scn (sc-number load-sc)))
1116 (setf (svref costs load-scn) 0)
1117 (setf (svref load-scs load-scn) t)
1118 (dolist (op-sc (append (when load-p
1119 (sc-constant-scs load-sc))
1120 (sc-alternate-scs load-sc)))
1121 (let* ((op-scn (sc-number op-sc))
1123 (aref (sc-load-costs load-sc) op-scn)
1124 (aref (sc-load-costs op-sc) load-scn))))
1126 (error "no move function defined to move ~:[from~;to~] SC ~
1127 ~S~%~:[to~;from~] alternate or constant SC ~S"
1128 load-p sc-name load-p (sc-name op-sc)))
1130 (let ((op-cost (svref costs op-scn)))
1131 (when (or (not op-cost) (< load op-cost))
1132 (setf (svref costs op-scn) load)))
1134 (let ((op-load (svref load-scs op-scn)))
1135 (unless (eq op-load t)
1136 (pushnew load-scn (svref load-scs op-scn))))))
1138 (dotimes (i sc-number-limit)
1139 (unless (svref costs i)
1140 (let ((op-sc (svref *backend-meta-sc-numbers* i)))
1142 (let ((cost (if load-p
1143 (svref (sc-move-costs load-sc) i)
1144 (svref (sc-move-costs op-sc) load-scn))))
1146 (setf (svref costs i) cost)))))))))
1148 (values costs load-scs)))
1150 (defparameter *no-costs*
1151 (make-array sc-number-limit :initial-element 0))
1153 (defparameter *no-loads*
1154 (make-array sc-number-limit :initial-element 't))
1156 ;;; Pick off the case of operands with no restrictions.
1157 (defun compute-loading-costs-if-any (op load-p)
1158 (declare (type operand-parse op))
1159 (if (operand-parse-scs op)
1160 (compute-loading-costs op load-p)
1161 (values *no-costs* *no-loads*)))
1163 (defun compute-costs-and-restrictions-list (ops load-p)
1164 (declare (list ops))
1168 (multiple-value-bind (costs scs) (compute-loading-costs-if-any op load-p)
1171 (values (costs) (scs))))
1173 (defun make-costs-and-restrictions (parse)
1174 (multiple-value-bind (arg-costs arg-scs)
1175 (compute-costs-and-restrictions-list (vop-parse-args parse) t)
1176 (multiple-value-bind (result-costs result-scs)
1177 (compute-costs-and-restrictions-list (vop-parse-results parse) nil)
1179 :cost ,(vop-parse-cost parse)
1181 :arg-costs ',arg-costs
1182 :arg-load-scs ',arg-scs
1183 :result-costs ',result-costs
1184 :result-load-scs ',result-scs
1187 ',(if (vop-parse-more-args parse)
1188 (compute-loading-costs-if-any (vop-parse-more-args parse) t)
1192 ',(if (vop-parse-more-results parse)
1193 (compute-loading-costs-if-any (vop-parse-more-results parse) nil)
1196 ;;;; operand checking and stuff
1198 ;;; Given a list of arg/result restrictions, check for valid syntax and
1199 ;;; convert to canonical form.
1200 (defun parse-operand-types (specs args-p)
1201 (declare (list specs))
1202 (labels ((parse-operand-type (spec)
1203 (cond ((eq spec '*) spec)
1205 (let ((alias (gethash spec
1206 *backend-primitive-type-aliases*)))
1208 (parse-operand-type alias)
1211 (error "bad thing to be a operand type: ~S" spec))
1215 (collect ((results))
1217 (dolist (item (cdr spec))
1218 (unless (symbolp item)
1219 (error "bad PRIMITIVE-TYPE name in ~S: ~S"
1223 *backend-primitive-type-aliases*)))
1225 (let ((alias (parse-operand-type alias)))
1226 (unless (eq (car alias) :or)
1227 (error "can't include primitive-type ~
1228 alias ~S in an :OR restriction: ~S"
1230 (dolist (x (cdr alias))
1233 (remove-duplicates (results)
1238 (error "can't :CONSTANT for a result"))
1239 (unless (= (length spec) 2)
1240 (error "bad :CONSTANT argument type spec: ~S" spec))
1243 (error "bad thing to be a operand type: ~S" spec)))))))
1244 (mapcar #'parse-operand-type specs)))
1246 ;;; Check the consistency of Op's Sc restrictions with the specified
1247 ;;; primitive-type restriction. :CONSTANT operands have already been filtered
1248 ;;; out, so only :OR and * restrictions are left.
1250 ;;; We check that every representation allowed by the type can be directly
1251 ;;; loaded into some SC in the restriction, and that the type allows every SC
1252 ;;; in the restriction. With *, we require that T satisfy the first test, and
1253 ;;; omit the second.
1254 (defun check-operand-type-scs (parse op type load-p)
1255 (declare (type vop-parse parse) (type operand-parse op))
1256 (let ((ptypes (if (eq type '*) (list 't) (rest type)))
1257 (scs (operand-parse-scs op)))
1259 (multiple-value-bind (costs load-scs) (compute-loading-costs op load-p)
1260 (declare (ignore costs))
1261 (dolist (ptype ptypes)
1262 (unless (dolist (rep (primitive-type-scs
1263 (meta-primitive-type-or-lose ptype))
1265 (when (svref load-scs rep) (return t)))
1266 (error "In the ~A ~:[result~;argument~] to VOP ~S,~@
1267 none of the SCs allowed by the operand type ~S can ~
1268 directly be loaded~@
1269 into any of the restriction's SCs:~% ~S~:[~;~@
1270 [* type operand must allow T's SCs.]~]"
1271 (operand-parse-name op) load-p (vop-parse-name parse)
1273 scs (eq type '*)))))
1276 (unless (or (eq type '*)
1277 (dolist (ptype ptypes nil)
1278 (when (meta-sc-allowed-by-primitive-type
1279 (meta-sc-or-lose sc)
1280 (meta-primitive-type-or-lose ptype))
1282 (warn "~:[Result~;Argument~] ~A to VOP ~S~@
1283 has SC restriction ~S which is ~
1284 not allowed by the operand type:~% ~S"
1285 load-p (operand-parse-name op) (vop-parse-name parse)
1290 ;;; If the operand types are specified, then check the number specified
1291 ;;; against the number of defined operands.
1292 (defun check-operand-types (parse ops more-op types load-p)
1293 (declare (type vop-parse parse) (list ops)
1294 (type (or list (member :unspecified)) types)
1295 (type (or operand-parse null) more-op))
1296 (unless (eq types :unspecified)
1297 (let ((num (+ (length ops) (if more-op 1 0))))
1298 (unless (= (count-if-not #'(lambda (x)
1300 (eq (car x) :constant)))
1303 (error "expected ~D ~:[result~;argument~] type~P: ~S"
1304 num load-p types num)))
1307 (let ((mtype (car (last types))))
1308 (when (and (consp mtype) (eq (first mtype) :constant))
1309 (error "can't use :CONSTANT on VOP more args")))))
1311 (when (vop-parse-translate parse)
1312 (let ((types (specify-operand-types types ops more-op)))
1313 (mapc #'(lambda (x y)
1314 (check-operand-type-scs parse x y load-p))
1315 (if more-op (butlast ops) ops)
1316 (remove-if #'(lambda (x)
1318 (eq (car x) ':constant)))
1319 (if more-op (butlast types) types)))))
1323 ;;; Compute stuff that can only be computed after we are done parsing
1324 ;;; everying. We set the VOP-Parse-Operands, and do various error checks.
1325 (defun grovel-operands (parse)
1326 (declare (type vop-parse parse))
1328 (setf (vop-parse-operands parse)
1329 (append (vop-parse-args parse)
1330 (if (vop-parse-more-args parse)
1331 (list (vop-parse-more-args parse)))
1332 (vop-parse-results parse)
1333 (if (vop-parse-more-results parse)
1334 (list (vop-parse-more-results parse)))
1335 (vop-parse-temps parse)))
1337 (check-operand-types parse
1338 (vop-parse-args parse)
1339 (vop-parse-more-args parse)
1340 (vop-parse-arg-types parse)
1343 (check-operand-types parse
1344 (vop-parse-results parse)
1345 (vop-parse-more-results parse)
1346 (vop-parse-result-types parse)
1351 ;;;; function translation stuff
1353 ;;; Return forms to establish this VOP as a IR2 translation template for the
1354 ;;; :Translate functions specified in the VOP-Parse. We also set the
1355 ;;; Predicate attribute for each translated function when the VOP is
1356 ;;; conditional, causing IR1 conversion to ensure that a call to the translated
1357 ;;; is always used in a predicate position.
1358 (defun set-up-function-translation (parse n-template)
1359 (declare (type vop-parse parse))
1360 (mapcar #'(lambda (name)
1361 `(let ((info (function-info-or-lose ',name)))
1362 (setf (function-info-templates info)
1363 (adjoin-template ,n-template
1364 (function-info-templates info)))
1365 ,@(when (vop-parse-conditional-p parse)
1366 '((setf (function-info-attributes info)
1368 (ir1-attributes predicate)
1369 (function-info-attributes info)))))))
1370 (vop-parse-translate parse)))
1372 ;;; Return a form that can be evaluated to get the TEMPLATE operand type
1373 ;;; restriction from the given specification.
1374 (defun make-operand-type (type)
1375 (cond ((eq type '*) ''*)
1377 ``(:or ,(primitive-type-or-lose ',type)))
1381 ``(:or ,,@(mapcar #'(lambda (type)
1382 `(primitive-type-or-lose ',type))
1385 ``(:constant ,#'(lambda (x)
1386 (typep x ',(second type)))
1387 ,',(second type)))))))
1389 (defun specify-operand-types (types ops more-ops)
1390 (if (eq types :unspecified)
1391 (make-list (+ (length ops) (if more-ops 1 0)) :initial-element '*)
1394 ;;; Return a list of forms to use as keyword args to Make-VOP-Info for
1395 ;;; setting up the template argument and result types. Here we make an initial
1396 ;;; dummy Template-Type, since it is awkward to compute the type until the
1397 ;;; template has been made.
1398 (defun make-vop-info-types (parse)
1399 (let* ((more-args (vop-parse-more-args parse))
1400 (all-args (specify-operand-types (vop-parse-arg-types parse)
1401 (vop-parse-args parse)
1403 (args (if more-args (butlast all-args) all-args))
1404 (more-arg (when more-args (car (last all-args))))
1405 (more-results (vop-parse-more-results parse))
1406 (all-results (specify-operand-types (vop-parse-result-types parse)
1407 (vop-parse-results parse)
1409 (results (if more-results (butlast all-results) all-results))
1410 (more-result (when more-results (car (last all-results))))
1411 (conditional (vop-parse-conditional-p parse)))
1414 :type (specifier-type '(function () nil))
1415 :arg-types (list ,@(mapcar #'make-operand-type args))
1416 :more-args-type ,(when more-args (make-operand-type more-arg))
1417 :result-types ,(if conditional
1419 `(list ,@(mapcar #'make-operand-type results)))
1420 :more-results-type ,(when more-results
1421 (make-operand-type more-result)))))
1423 ;;;; setting up VOP-INFO
1425 (eval-when (:compile-toplevel :load-toplevel :execute)
1426 (defparameter *slot-inherit-alist*
1427 '((:generator-function . vop-info-generator-function))))
1429 ;;; Something to help with inheriting VOP-Info slots. We return a
1430 ;;; keyword/value pair that can be passed to the constructor. Slot is the
1431 ;;; keyword name of the slot, Parse is a form that evaluates to the VOP-Parse
1432 ;;; structure for the VOP inherited. If Parse is NIL, then we do nothing. If
1433 ;;; the Test form evaluates to true, then we return a form that selects the
1434 ;;; named slot from the VOP-Info structure corresponding to Parse. Otherwise,
1435 ;;; we return the Form so that the slot is recomputed.
1436 (defmacro inherit-vop-info (slot parse test form)
1437 `(if (and ,parse ,test)
1438 (list ,slot `(,',(or (cdr (assoc slot *slot-inherit-alist*))
1439 (error "unknown slot ~S" slot))
1440 (template-or-lose ',(vop-parse-name ,parse))))
1441 (list ,slot ,form)))
1443 ;;; Return a form that creates a VOP-Info structure which describes VOP.
1444 (defun set-up-vop-info (iparse parse)
1445 (declare (type vop-parse parse) (type (or vop-parse null) iparse))
1446 (let ((same-operands
1448 (equal (vop-parse-operands parse)
1449 (vop-parse-operands iparse))
1450 (equal (vop-parse-info-args iparse)
1451 (vop-parse-info-args parse))))
1452 (variant (vop-parse-variant parse)))
1454 (let ((nvars (length (vop-parse-variant-vars parse))))
1455 (unless (= (length variant) nvars)
1456 (error "expected ~D variant values: ~S" nvars variant)))
1459 :name ',(vop-parse-name parse)
1460 ,@(make-vop-info-types parse)
1461 :guard ,(when (vop-parse-guard parse)
1462 `#'(lambda () ,(vop-parse-guard parse)))
1463 :note ',(vop-parse-note parse)
1464 :info-arg-count ,(length (vop-parse-info-args parse))
1465 :policy ',(vop-parse-policy parse)
1466 :save-p ',(vop-parse-save-p parse)
1467 :move-args ',(vop-parse-move-args parse)
1468 :effects (vop-attributes ,@(vop-parse-effects parse))
1469 :affected (vop-attributes ,@(vop-parse-affected parse))
1470 ,@(make-costs-and-restrictions parse)
1471 ,@(make-emit-function-and-friends parse)
1472 ,@(inherit-vop-info :generator-function iparse
1474 (equal (vop-parse-body parse) (vop-parse-body iparse)))
1475 (unless (eq (vop-parse-body parse) :unspecified)
1476 (make-generator-function parse)))
1477 :variant (list ,@variant))))
1479 ;;; Parse the syntax into a VOP-Parse structure, and then expand into code
1480 ;;; that creates the appropriate VOP-Info structure at load time. We implement
1481 ;;; inheritance by copying the VOP-Parse structure for the inherited structure.
1482 (def!macro define-vop ((name &optional inherits) &rest specs)
1484 "Define-VOP (Name [Inherits]) Spec*
1485 Define the symbol Name to be a Virtual OPeration in the compiler. If
1486 specified, Inherits is the name of a VOP that we default unspecified
1487 information from. Each Spec is a list beginning with a keyword indicating
1488 the interpretation of the other forms in the Spec:
1490 :Args {(Name {Key Value}*)}*
1491 :Results {(Name {Key Value}*)}*
1492 The Args and Results are specifications of the operand TNs passed to the
1493 VOP. If there is an inherited VOP, any unspecified options are defaulted
1494 from the inherited argument (or result) of the same name. The following
1495 operand options are defined:
1498 :SCs specifies good SCs for this operand. Other SCs will be
1499 penalized according to move costs. A load TN will be allocated if
1500 necessary, guaranteeing that the operand is always one of the
1504 Load-Name is bound to the load TN allocated for this operand, or to
1505 NIL if no load TN was allocated.
1508 Controls whether automatic operand loading is done. Expression is
1509 evaluated with the fixed operand TNs bound. If Expression is true,
1510 then loading is done and the variable is bound to the load TN in
1511 the generator body. Otherwise, loading is not done, and the variable
1512 is bound to the actual operand.
1515 If specified, Name is bound to the TN-Ref for the first argument or
1516 result following the fixed arguments or results. A more operand must
1517 appear last, and cannot be targeted or restricted.
1520 This operand is targeted to the named operand, indicating a desire to
1521 pack in the same location. Not legal for results.
1525 Specify the beginning or end of the operand's lifetime. :From can
1526 only be used with results, and :To only with arguments. The default
1527 for the N'th argument/result is (:ARGUMENT N)/(:RESULT N). These
1528 options are necessary primarily when operands are read or written out
1532 This is used in place of :RESULTS with conditional branch VOPs. There
1533 are no result values: the result is a transfer of control. The target
1534 label is passed as the first :INFO arg. The second :INFO arg is true if
1535 the sense of the test should be negated. A side-effect is to set the
1536 PREDICATE attribute for functions in the :TRANSLATE option.
1538 :Temporary ({Key Value}*) Name*
1539 Allocate a temporary TN for each Name, binding that variable to the TN
1540 within the body of the generators. In addition to :Target (which is
1541 is the same as for operands), the following options are
1546 Force the temporary to be allocated in the specified SC with the
1547 specified offset. Offset is evaluated at macroexpand time. If
1548 Offset is emitted, the register allocator chooses a free location in
1549 SC. If both SC and Offset are omitted, then the temporary is packed
1550 according to its primitive type.
1554 Similar to the argument/result option, this specifies the start and
1555 end of the temporaries' lives. The defaults are :Load and :Save,
1556 i.e. the duration of the VOP. The other intervening phases are
1557 :Argument,:Eval and :Result. Non-zero sub-phases can be specified
1558 by a list, e.g. by default the second argument's life ends at
1561 :Generator Cost Form*
1562 Specifies the translation into assembly code. Cost is the estimated cost
1563 of the code emitted by this generator. The body is arbitrary Lisp code
1564 that emits the assembly language translation of the VOP. An Assemble
1565 form is wrapped around the body, so code may be emitted by using the
1566 local Inst macro. During the evaluation of the body, the names of the
1567 operands and temporaries are bound to the actual TNs.
1571 Specifies the side effects that this VOP has and the side effects that
1572 effect its execution. If unspecified, these default to the worst case.
1575 Define some magic arguments that are passed directly to the code
1576 generator. The corresponding trailing arguments to VOP or %Primitive are
1577 stored in the VOP structure. Within the body of the generators, the
1578 named variables are bound to these values. Except in the case of
1579 :Conditional VOPs, :Info arguments cannot be specified for VOPS that are
1580 the direct translation for a function (specified by :Translate).
1583 Causes the named variables to be declared IGNORE in the generator body.
1587 These options provide a way to parameterize families of VOPs that differ
1588 only trivially. :Variant makes the specified evaluated Things be the
1589 \"variant\" associated with this VOP. :Variant-Vars causes the named
1590 variables to be bound to the corresponding Things within the body of the
1594 Specifies the cost of this VOP, overriding the cost of any inherited
1597 :Note {String | NIL}
1598 A short noun-like phrase describing what this VOP \"does\", i.e. the
1599 implementation strategy. If supplied, efficency notes will be generated
1600 when type uncertainty prevents :TRANSLATE from working. NIL inhibits any
1603 :Arg-Types {* | PType | (:OR PType*) | (:CONSTANT Type)}*
1604 :Result-Types {* | PType | (:OR PType*)}*
1605 Specify the template type restrictions used for automatic translation.
1606 If there is a :More operand, the last type is the more type. :CONSTANT
1607 specifies that the argument must be a compile-time constant of the
1608 specified Lisp type. The constant values of :CONSTANT arguments are
1609 passed as additional :INFO arguments rather than as :ARGS.
1612 This option causes the VOP template to be entered as an IR2 translation
1613 for the named functions.
1615 :Policy {:Small | :Fast | :Safe | :Fast-Safe}
1616 Specifies the policy under which this VOP is the best translation.
1619 Specifies a Form that is evaluated in the global environment. If
1620 form returns NIL, then emission of this VOP is prohibited even when
1621 all other restrictions are met.
1625 In the generator, bind the specified variable to the VOP or the Node that
1628 :Save-P {NIL | T | :Compute-Only | :Force-To-Stack}
1629 Indicates how a VOP wants live registers saved.
1631 :Move-Args {NIL | :Full-Call | :Local-Call | :Known-Return}
1632 Indicates if and how the more args should be moved into a different
1634 (check-type name symbol)
1636 (let* ((iparse (when inherits
1637 (vop-parse-or-lose inherits)))
1639 (copy-vop-parse iparse)
1642 (setf (vop-parse-name parse) name)
1643 (setf (vop-parse-inherits parse) inherits)
1645 (parse-define-vop parse specs)
1646 (grovel-operands parse)
1649 (eval-when (:compile-toplevel :load-toplevel :execute)
1650 (setf (gethash ',name *backend-parsed-vops*)
1653 (let ((,n-res ,(set-up-vop-info iparse parse)))
1654 (setf (gethash ',name *backend-template-names*) ,n-res)
1655 (setf (template-type ,n-res)
1656 (specifier-type (template-type-specifier ,n-res)))
1657 ,@(set-up-function-translation parse n-res))
1660 ;;;; emission macros
1662 ;;; Return code to make a list of VOP arguments or results, linked by
1663 ;;; TN-Ref-Across. The first value is code, the second value is LET* forms,
1664 ;;; and the third value is a variable that evaluates to the head of the list,
1665 ;;; or NIL if there are no operands. Fixed is a list of forms that evaluate to
1666 ;;; TNs for the fixed operands. TN-Refs will be made for these operands
1667 ;;; according using the specified value of Write-P. More is an expression that
1668 ;;; evaluates to a list of TN-Refs that will be made the tail of the list. If
1669 ;;; it is constant NIL, then we don't bother to set the tail.
1670 (defun make-operand-list (fixed more write-p)
1676 (let ((n-ref (gensym)))
1677 (binds `(,n-ref (reference-tn ,op ,write-p)))
1679 (forms `(setf (tn-ref-across ,n-prev) ,n-ref))
1680 (setq n-head n-ref))
1681 (setq n-prev n-ref)))
1684 (let ((n-more (gensym)))
1685 (binds `(,n-more ,more))
1687 (forms `(setf (tn-ref-across ,n-prev) ,n-more))
1688 (setq n-head n-more))))
1690 (values (forms) (binds) n-head))))
1692 (defmacro emit-template (node block template args results &optional info)
1694 "Emit-Template Node Block Template Args Results [Info]
1695 Call the emit function for Template, linking the result in at the end of
1697 (let ((n-first (gensym))
1699 (once-only ((n-node node)
1701 (n-template template))
1702 `(multiple-value-bind (,n-first ,n-last)
1703 (funcall (template-emit-function ,n-template)
1704 ,n-node ,n-block ,n-template ,args ,results
1705 ,@(when info `(,info)))
1706 (insert-vop-sequence ,n-first ,n-last ,n-block nil)))))
1708 (defmacro vop (name node block &rest operands)
1710 "VOP Name Node Block Arg* Info* Result*
1711 Emit the VOP (or other template) Name at the end of the IR2-Block Block,
1712 using Node for the source context. The interpretation of the remaining
1713 arguments depends on the number of operands of various kinds that are
1714 declared in the template definition. VOP cannot be used for templates that
1715 have more-args or more-results, since the number of arguments and results is
1716 indeterminate for these templates. Use VOP* instead.
1718 Args and Results are the TNs that are to be referenced by the template
1719 as arguments and results. If the template has codegen-info arguments, then
1720 the appropriate number of Info forms following the Arguments are used for
1722 (let* ((parse (vop-parse-or-lose name))
1723 (arg-count (length (vop-parse-args parse)))
1724 (result-count (length (vop-parse-results parse)))
1725 (info-count (length (vop-parse-info-args parse)))
1726 (noperands (+ arg-count result-count info-count))
1729 (n-template (gensym)))
1731 (when (or (vop-parse-more-args parse) (vop-parse-more-results parse))
1732 (error "cannot use VOP with variable operand count templates"))
1733 (unless (= noperands (length operands))
1734 (error "called with ~D operands, but was expecting ~D"
1735 (length operands) noperands))
1737 (multiple-value-bind (acode abinds n-args)
1738 (make-operand-list (subseq operands 0 arg-count) nil nil)
1739 (multiple-value-bind (rcode rbinds n-results)
1740 (make-operand-list (subseq operands (+ arg-count info-count)) nil t)
1744 (dolist (info (subseq operands arg-count (+ arg-count info-count)))
1745 (let ((temp (gensym)))
1746 (ibinds `(,temp ,info))
1749 `(let* ((,n-node ,node)
1751 (,n-template (template-or-lose ',name))
1757 (emit-template ,n-node ,n-block ,n-template ,n-args
1760 `((list ,@(ivars)))))
1763 (defmacro vop* (name node block args results &rest info)
1765 "VOP* Name Node Block (Arg* More-Args) (Result* More-Results) Info*
1766 Like VOP, but allows for emission of templates with arbitrary numbers of
1767 arguments, and for emission of templates using already-created TN-Ref lists.
1769 The Arguments and Results are TNs to be referenced as the first arguments
1770 and results to the template. More-Args and More-Results are heads of TN-Ref
1771 lists that are added onto the end of the TN-Refs for the explicitly supplied
1772 operand TNs. The TN-Refs for the more operands must have the TN and Write-P
1773 slots correctly initialized.
1775 As with VOP, the Info forms are evaluated and passed as codegen info
1777 (check-type args cons)
1778 (check-type results cons)
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 (fixed-args (butlast args))
1784 (fixed-results (butlast results))
1787 (n-template (gensym)))
1789 (unless (or (vop-parse-more-args parse)
1790 (<= (length fixed-args) arg-count))
1791 (error "too many fixed arguments"))
1792 (unless (or (vop-parse-more-results parse)
1793 (<= (length fixed-results) result-count))
1794 (error "too many fixed results"))
1795 (unless (= (length info) info-count)
1796 (error "expected ~D info args" info-count))
1798 (multiple-value-bind (acode abinds n-args)
1799 (make-operand-list fixed-args (car (last args)) nil)
1800 (multiple-value-bind (rcode rbinds n-results)
1801 (make-operand-list fixed-results (car (last results)) t)
1803 `(let* ((,n-node ,node)
1805 (,n-template (template-or-lose ',name))
1810 (emit-template ,n-node ,n-block ,n-template ,n-args ,n-results
1815 ;;;; miscellaneous macros
1817 (def!macro sc-case (tn &rest forms)
1819 "SC-Case TN {({(SC-Name*) | SC-Name | T} Form*)}*
1820 Case off of TN's SC. The first clause containing TN's SC is evaluated,
1821 returning the values of the last form. A clause beginning with T specifies a
1822 default. If it appears, it must be last. If no default is specified, and no
1823 clause matches, then an error is signalled."
1824 (let ((n-sc (gensym))
1826 (collect ((clauses))
1827 (do ((cases forms (rest cases)))
1829 (clauses `(t (error "unknown SC to SC-Case for ~S:~% ~S" ,n-tn
1830 (sc-name (tn-sc ,n-tn))))))
1831 (let ((case (first cases)))
1833 (error "illegal SC-Case clause: ~S" case))
1834 (let ((head (first case)))
1837 (error "T case is not last in SC-Case."))
1838 (clauses `(t nil ,@(rest case)))
1840 (clauses `((or ,@(mapcar #'(lambda (x)
1841 `(eql ,(meta-sc-number-or-lose x)
1843 (if (atom head) (list head) head)))
1844 nil ,@(rest case))))))
1847 (,n-sc (sc-number (tn-sc ,n-tn))))
1848 (cond ,@(clauses))))))
1850 (defmacro sc-is (tn &rest scs)
1853 Returns true if TNs SC is any of the named SCs, false otherwise."
1854 (once-only ((n-sc `(sc-number (tn-sc ,tn))))
1855 `(or ,@(mapcar #'(lambda (x)
1856 `(eql ,n-sc ,(meta-sc-number-or-lose x)))
1859 (defmacro do-ir2-blocks ((block-var component &optional result)
1862 "Do-IR2-Blocks (Block-Var Component [Result]) Form*
1863 Iterate over the IR2 blocks in component, in emission order."
1864 `(do ((,block-var (block-info (component-head ,component))
1865 (ir2-block-next ,block-var)))
1866 ((null ,block-var) ,result)
1869 (defmacro do-live-tns ((tn-var live block &optional result) &body body)
1871 "DO-LIVE-TNS (TN-Var Live Block [Result]) Form*
1872 Iterate over all the TNs live at some point, with the live set represented by
1873 a local conflicts bit-vector and the IR2-Block containing the location."
1874 (let ((n-conf (gensym))
1878 (once-only ((n-live live)
1881 (flet ((,n-bod (,tn-var) ,@body))
1882 ;; Do component-live TNs.
1883 (dolist (,tn-var (ir2-component-component-tns
1886 (ir2-block-block ,n-block)))))
1889 (let ((,ltns (ir2-block-local-tns ,n-block)))
1890 ;; Do TNs always-live in this block and live :More TNs.
1891 (do ((,n-conf (ir2-block-global-tns ,n-block)
1892 (global-conflicts-next ,n-conf)))
1894 (when (or (eq (global-conflicts-kind ,n-conf) :live)
1895 (let ((,i (global-conflicts-number ,n-conf)))
1896 (and (eq (svref ,ltns ,i) :more)
1897 (not (zerop (sbit ,n-live ,i))))))
1898 (,n-bod (global-conflicts-tn ,n-conf))))
1899 ;; Do TNs locally live in the designated live set.
1900 (dotimes (,i (ir2-block-local-tn-count ,n-block) ,result)
1901 (unless (zerop (sbit ,n-live ,i))
1902 (let ((,tn-var (svref ,ltns ,i)))
1903 (when (and ,tn-var (not (eq ,tn-var :more)))
1904 (,n-bod ,tn-var)))))))))))
1906 (defmacro do-environment-ir2-blocks ((block-var env &optional result)
1909 "DO-ENVIRONMENT-IR2-BLOCKS (Block-Var Env [Result]) Form*
1910 Iterate over all the IR2 blocks in the environment Env, in emit order."
1911 (once-only ((n-env env))
1912 (once-only ((n-first `(node-block
1914 (environment-function ,n-env)))))
1915 (once-only ((n-tail `(block-info
1917 (block-component ,n-first)))))
1918 `(do ((,block-var (block-info ,n-first)
1919 (ir2-block-next ,block-var)))
1920 ((or (eq ,block-var ,n-tail)
1921 (not (eq (ir2-block-environment ,block-var) ,n-env)))