1.0.29.13: relax CAST-EXTERNALLY-CHECKABLE-P a bit
[sbcl.git] / src / compiler / meta-vmdef.lisp
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.
6 ;;;;
7 ;;;; FIXME: The "trashing the running [CMU CL] compiler" motivation no
8 ;;;; longer makes sense in SBCL, since we can cross-compile cleanly.
9
10 ;;;; This software is part of the SBCL system. See the README file for
11 ;;;; more information.
12 ;;;;
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.
18
19 (in-package "SB!C")
20 \f
21 ;;;; storage class and storage base definition
22
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.
27 ;;;
28 ;;; We enter the basic structure at meta-compile time, and then fill
29 ;;; in the missing slots at load time.
30 (defmacro define-storage-base (name kind &key size)
31
32   (declare (type symbol name))
33   (declare (type (member :finite :unbounded :non-packed) kind))
34
35   ;; SIZE is either mandatory or forbidden.
36   (ecase kind
37     (:non-packed
38      (when size
39        (error "A size specification is meaningless in a ~S SB." kind)))
40     ((:finite :unbounded)
41      (unless size (error "Size is not specified in a ~S SB." kind))
42      (aver (typep size 'unsigned-byte))))
43
44   (let ((res (if (eq kind :non-packed)
45                  (make-sb :name name :kind kind)
46                  (make-finite-sb :name name :kind kind :size size))))
47     `(progn
48        (eval-when (:compile-toplevel :load-toplevel :execute)
49          (/show0 "about to SETF GETHASH META-SB-NAMES in DEFINE-STORAGE-BASE")
50          (setf (gethash ',name *backend-meta-sb-names*)
51                ',res))
52        (/show0 "about to SETF GETHASH SB-NAMES in DEFINE-STORAGE-BASE")
53        ,(if (eq kind :non-packed)
54             `(setf (gethash ',name *backend-sb-names*)
55                    (copy-sb ',res))
56             `(let ((res (copy-finite-sb ',res)))
57                (/show0 "not :NON-PACKED, i.e. hairy case")
58                (setf (finite-sb-always-live res)
59                      (make-array ',size
60                                  :initial-element
61                                  #-(or sb-xc sb-xc-host) #*
62                                  ;; The cross-compiler isn't very good
63                                  ;; at dumping specialized arrays; we
64                                  ;; work around that by postponing
65                                  ;; generation of the specialized
66                                  ;; array 'til runtime.
67                                  #+(or sb-xc sb-xc-host)
68                                  (make-array 0 :element-type 'bit)))
69                (/show0 "doing second SETF")
70                (setf (finite-sb-conflicts res)
71                      (make-array ',size :initial-element '#()))
72                (/show0 "doing third SETF")
73                (setf (finite-sb-live-tns res)
74                      (make-array ',size :initial-element nil))
75                (/show0 "doing fourth SETF")
76                (setf (finite-sb-always-live-count res)
77                      (make-array ',size :initial-element 0))
78                (/show0 "doing fifth and final SETF")
79                (setf (gethash ',name *backend-sb-names*)
80                      res)))
81
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")
87        ',name)))
88
89 ;;; Define a storage class NAME that uses the named Storage-Base.
90 ;;; NUMBER is a small, non-negative integer that is used as an alias.
91 ;;; The following keywords are defined:
92 ;;;
93 ;;; :ELEMENT-SIZE Size
94 ;;;   The size of objects in this SC in whatever units the SB uses.
95 ;;;   This defaults to 1.
96 ;;;
97 ;;; :ALIGNMENT Size
98 ;;;   The alignment restrictions for this SC. TNs will only be
99 ;;;   allocated at offsets that are an even multiple of this number.
100 ;;;   This defaults to 1.
101 ;;;
102 ;;; :LOCATIONS (Location*)
103 ;;;   If the SB is :FINITE, then this is a list of the offsets within
104 ;;;   the SB that are in this SC.
105 ;;;
106 ;;; :RESERVE-LOCATIONS (Location*)
107 ;;;   A subset of the Locations that the register allocator should try to
108 ;;;   reserve for operand loading (instead of to hold variable values.)
109 ;;;
110 ;;; :SAVE-P {T | NIL}
111 ;;;   If T, then values stored in this SC must be saved in one of the
112 ;;;   non-save-p :ALTERNATE-SCs across calls.
113 ;;;
114 ;;; :ALTERNATE-SCS (SC*)
115 ;;;   Indicates other SCs that can be used to hold values from this SC across
116 ;;;   calls or when storage in this SC is exhausted. The SCs should be
117 ;;;   specified in order of decreasing \"goodness\". There must be at least
118 ;;;   one SC in an unbounded SB, unless this SC is only used for restricted or
119 ;;;   wired TNs.
120 ;;;
121 ;;; :CONSTANT-SCS (SC*)
122 ;;;   A list of the names of all the constant SCs that can be loaded into this
123 ;;;   SC by a move function.
124 (defmacro define-storage-class (name number sb-name &key (element-size '1)
125                                      (alignment '1) locations reserve-locations
126                                      save-p alternate-scs constant-scs)
127   (declare (type symbol name))
128   (declare (type sc-number number))
129   (declare (type symbol sb-name))
130   (declare (type list locations reserve-locations alternate-scs constant-scs))
131   (declare (type boolean save-p))
132   (unless (= (logcount alignment) 1)
133     (error "alignment not a power of two: ~W" alignment))
134
135   (let ((sb (meta-sb-or-lose sb-name)))
136     (if (eq (sb-kind sb) :finite)
137         (let ((size (sb-size sb))
138               (element-size (eval element-size)))
139           (declare (type unsigned-byte element-size))
140           (dolist (el locations)
141             (declare (type unsigned-byte el))
142             (unless (<= 1 (+ el element-size) size)
143               (error "SC element ~W out of bounds for ~S" el sb))))
144         (when locations
145           (error ":LOCATIONS is meaningless in a ~S SB." (sb-kind sb))))
146
147     (unless (subsetp reserve-locations locations)
148       (error "RESERVE-LOCATIONS not a subset of LOCATIONS."))
149
150     (when (and (or alternate-scs constant-scs)
151                (eq (sb-kind sb) :non-packed))
152       (error
153        "It's meaningless to specify alternate or constant SCs in a ~S SB."
154        (sb-kind sb))))
155
156   (let ((nstack-p
157          (if (or (eq sb-name 'non-descriptor-stack)
158                  (find 'non-descriptor-stack
159                        (mapcar #'meta-sc-or-lose alternate-scs)
160                        :key (lambda (x)
161                               (sb-name (sc-sb x)))))
162              t nil)))
163     `(progn
164        (eval-when (:compile-toplevel :load-toplevel :execute)
165          (let ((res (make-sc :name ',name :number ',number
166                              :sb (meta-sb-or-lose ',sb-name)
167                              :element-size ,element-size
168                              :alignment ,alignment
169                              :locations ',locations
170                              :reserve-locations ',reserve-locations
171                              :save-p ',save-p
172                              :number-stack-p ,nstack-p
173                              :alternate-scs (mapcar #'meta-sc-or-lose
174                                                     ',alternate-scs)
175                              :constant-scs (mapcar #'meta-sc-or-lose
176                                                    ',constant-scs))))
177            (setf (gethash ',name *backend-meta-sc-names*) res)
178            (setf (svref *backend-meta-sc-numbers* ',number) res)
179            (setf (svref (sc-load-costs res) ',number) 0)))
180
181        (let ((old (svref *backend-sc-numbers* ',number)))
182          (when (and old (not (eq (sc-name old) ',name)))
183            (warn "redefining SC number ~W from ~S to ~S" ',number
184                  (sc-name old) ',name)))
185
186        (setf (svref *backend-sc-numbers* ',number)
187              (meta-sc-or-lose ',name))
188        (setf (gethash ',name *backend-sc-names*)
189              (meta-sc-or-lose ',name))
190        (setf (sc-sb (sc-or-lose ',name)) (sb-or-lose ',sb-name))
191        ',name)))
192 \f
193 ;;;; move/coerce definition
194
195 ;;; Given a list of pairs of lists of SCs (as given to DEFINE-MOVE-VOP,
196 ;;; etc.), bind TO-SC and FROM-SC to all the combinations.
197 (defmacro do-sc-pairs ((from-sc-var to-sc-var scs) &body body)
198   `(do ((froms ,scs (cddr froms))
199         (tos (cdr ,scs) (cddr tos)))
200        ((null froms))
201      (dolist (from (car froms))
202        (let ((,from-sc-var (meta-sc-or-lose from)))
203          (dolist (to (car tos))
204            (let ((,to-sc-var (meta-sc-or-lose to)))
205              ,@body))))))
206
207 ;;; Define the function NAME and note it as the function used for
208 ;;; moving operands from the From-SCs to the To-SCs. Cost is the cost
209 ;;; of this move operation. The function is called with three
210 ;;; arguments: the VOP (for context), and the source and destination
211 ;;; TNs. An ASSEMBLE form is wrapped around the body. All uses of
212 ;;; DEFINE-MOVE-FUN should be compiled before any uses of
213 ;;; DEFINE-VOP.
214 (defmacro define-move-fun ((name cost) lambda-list scs &body body)
215   (declare (type index cost))
216   (when (or (oddp (length scs)) (null scs))
217     (error "malformed SCs spec: ~S" scs))
218   `(progn
219      (eval-when (:compile-toplevel :load-toplevel :execute)
220        (do-sc-pairs (from-sc to-sc ',scs)
221          (unless (eq from-sc to-sc)
222            (let ((num (sc-number from-sc)))
223              (setf (svref (sc-move-funs to-sc) num) ',name)
224              (setf (svref (sc-load-costs to-sc) num) ',cost)))))
225
226      (defun ,name ,lambda-list
227        (sb!assem:assemble (*code-segment* ,(first lambda-list))
228          ,@body))))
229
230 (eval-when (:compile-toplevel :load-toplevel :execute)
231   (defparameter *sc-vop-slots*
232     '((:move . sc-move-vops)
233       (:move-arg . sc-move-arg-vops))))
234
235 ;;; Make NAME be the VOP used to move values in the specified FROM-SCs
236 ;;; to the representation of the TO-SCs of each SC pair in SCS.
237 ;;;
238 ;;; If KIND is :MOVE-ARG, then the VOP takes an extra argument,
239 ;;; which is the frame pointer of the frame to move into.
240 ;;;
241 ;;; We record the VOP and costs for all SCs that we can move between
242 ;;; (including implicit loading).
243 (defmacro define-move-vop (name kind &rest scs)
244   (when (or (oddp (length scs)) (null scs))
245     (error "malformed SCs spec: ~S" scs))
246   (let ((accessor (or (cdr (assoc kind *sc-vop-slots*))
247                       (error "unknown kind ~S" kind))))
248     `(progn
249        ,@(when (eq kind :move)
250            `((eval-when (:compile-toplevel :load-toplevel :execute)
251                (do-sc-pairs (from-sc to-sc ',scs)
252                  (compute-move-costs from-sc to-sc
253                                      ,(vop-parse-cost
254                                        (vop-parse-or-lose name)))))))
255
256        (let ((vop (template-or-lose ',name)))
257          (do-sc-pairs (from-sc to-sc ',scs)
258            (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc)))
259              (let ((vec (,accessor dest-sc)))
260                (let ((scn (sc-number from-sc)))
261                  (setf (svref vec scn)
262                        (adjoin-template vop (svref vec scn))))
263                (dolist (sc (append (sc-alternate-scs from-sc)
264                                    (sc-constant-scs from-sc)))
265                  (let ((scn (sc-number sc)))
266                    (setf (svref vec scn)
267                          (adjoin-template vop (svref vec scn))))))))))))
268 \f
269 ;;;; primitive type definition
270
271 (defun meta-primitive-type-or-lose (name)
272   (the primitive-type
273        (or (gethash name *backend-meta-primitive-type-names*)
274            (error "~S is not a defined primitive type." name))))
275
276 ;;; Define a primitive type NAME. Each SCS entry specifies a storage
277 ;;; class that values of this type may be allocated in. TYPE is the
278 ;;; type descriptor for the Lisp type that is equivalent to this type.
279 (defmacro !def-primitive-type (name scs &key (type name))
280   (declare (type symbol name) (type list scs))
281   (let ((scns (mapcar #'meta-sc-number-or-lose scs)))
282     `(progn
283        (/show0 "doing !DEF-PRIMITIVE-TYPE, NAME=..")
284        (/primitive-print ,(symbol-name name))
285        (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
286          (setf (gethash ',name *backend-meta-primitive-type-names*)
287                (make-primitive-type :name ',name
288                                     :scs ',scns
289                                     :specifier ',type)))
290        ,(once-only ((n-old `(gethash ',name *backend-primitive-type-names*)))
291           `(progn
292              ;; If the PRIMITIVE-TYPE structure already exists, we
293              ;; destructively modify it so that existing references in
294              ;; templates won't be invalidated. FIXME: This should no
295              ;; longer be an issue in SBCL, since we don't try to do
296              ;; serious surgery on ourselves. Probably this should
297              ;; just become an assertion that N-OLD is NIL, so that we
298              ;; don't have to try to maintain the correctness of the
299              ;; never-ordinarily-used clause.
300              (/show0 "in !DEF-PRIMITIVE-TYPE, about to COND")
301              (cond (,n-old
302                     (/show0 "in ,N-OLD clause of COND")
303                     (setf (primitive-type-scs ,n-old) ',scns)
304                     (setf (primitive-type-specifier ,n-old) ',type))
305                    (t
306                     (/show0 "in T clause of COND")
307                     (setf (gethash ',name *backend-primitive-type-names*)
308                           (make-primitive-type :name ',name
309                                                :scs ',scns
310                                                :specifier ',type))))
311              (/show0 "done with !DEF-PRIMITIVE-TYPE")
312              ',name)))))
313
314 ;;; Define NAME to be an alias for RESULT in VOP operand type restrictions.
315 (defmacro !def-primitive-type-alias (name result)
316   ;; Just record the translation.
317   `(eval-when (:compile-toplevel :load-toplevel :execute)
318      (setf (gethash ',name *backend-primitive-type-aliases*) ',result)
319      ',name))
320
321 (defparameter *primitive-type-slot-alist*
322   '((:check . primitive-type-check)))
323
324 ;;;  Primitive-Type-VOP Vop (Kind*) Type*
325 ;;;
326 ;;; Annotate all the specified primitive Types with the named VOP
327 ;;; under each of the specified kinds:
328 ;;;
329 ;;; :CHECK
330 ;;;    A one-argument one-result VOP that moves the argument to the
331 ;;;    result, checking that the value is of this type in the process.
332 (defmacro primitive-type-vop (vop kinds &rest types)
333   (let ((n-vop (gensym))
334         (n-type (gensym)))
335     `(let ((,n-vop (template-or-lose ',vop)))
336        ,@(mapcar
337           (lambda (type)
338             `(let ((,n-type (primitive-type-or-lose ',type)))
339                ,@(mapcar
340                   (lambda (kind)
341                     (let ((slot (or (cdr (assoc kind
342                                                 *primitive-type-slot-alist*))
343                                     (error "unknown kind: ~S" kind))))
344                       `(setf (,slot ,n-type) ,n-vop)))
345                   kinds)))
346           types)
347        nil)))
348
349 ;;; Return true if SC is either one of PTYPE's SC's, or one of those
350 ;;; SC's alternate or constant SCs.
351 (defun meta-sc-allowed-by-primitive-type (sc ptype)
352   (declare (type sc sc) (type primitive-type ptype))
353   (let ((scn (sc-number sc)))
354     (dolist (allowed (primitive-type-scs ptype) nil)
355       (when (eql allowed scn)
356         (return t))
357       (let ((allowed-sc (svref *backend-meta-sc-numbers* allowed)))
358         (when (or (member sc (sc-alternate-scs allowed-sc))
359                   (member sc (sc-constant-scs allowed-sc)))
360           (return t))))))
361 \f
362 ;;;; VOP definition structures
363 ;;;;
364 ;;;; DEFINE-VOP uses some fairly complex data structures at
365 ;;;; meta-compile time, both to hold the results of parsing the
366 ;;;; elaborate syntax and to retain the information so that it can be
367 ;;;; inherited by other VOPs.
368
369 ;;; A VOP-PARSE object holds everything we need to know about a VOP at
370 ;;; meta-compile time.
371 (def!struct (vop-parse
372              (:make-load-form-fun just-dump-it-normally)
373              #-sb-xc-host (:pure t))
374   ;; the name of this VOP
375   (name nil :type symbol)
376   ;; If true, then the name of the VOP we inherit from.
377   (inherits nil :type (or symbol null))
378   ;; lists of OPERAND-PARSE structures describing the arguments,
379   ;; results and temporaries of the VOP
380   (args nil :type list)
381   (results nil :type list)
382   (temps nil :type list)
383   ;; OPERAND-PARSE structures containing information about more args
384   ;; and results. If null, then there there are no more operands of
385   ;; that kind
386   (more-args nil :type (or operand-parse null))
387   (more-results nil :type (or operand-parse null))
388   ;; a list of all the above together
389   (operands nil :type list)
390   ;; names of variables that should be declared IGNORE
391   (ignores () :type list)
392   ;; true if this is a :CONDITIONAL VOP. T if a branchful VOP,
393   ;; a list of condition descriptor otherwise. See $ARCH/pred.lisp
394   ;; for more information.
395   (conditional-p nil)
396   ;; argument and result primitive types. These are pulled out of the
397   ;; operands, since we often want to change them without respecifying
398   ;; the operands.
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
402   (guard nil)
403   ;; the cost of and body code for the generator
404   (cost 0 :type unsigned-byte)
405   (body :unspecified :type (or (member :unspecified) list))
406   ;; info for VOP variants. The list of forms to be evaluated to get
407   ;; the variant args for this VOP, and the list of variables to be
408   ;; bound to the variant args.
409   (variant () :type list)
410   (variant-vars () :type list)
411   ;; variables bound to the VOP and Vop-Node when in the generator body
412   (vop-var '.vop. :type symbol)
413   (node-var nil :type (or symbol null))
414   ;; a list of the names of the codegen-info arguments to this VOP
415   (info-args () :type list)
416   ;; an efficiency note associated with this VOP
417   (note nil :type (or string null))
418   ;; a list of the names of the Effects and Affected attributes for
419   ;; this VOP
420   (effects '#1=(any) :type list)
421   (affected '#1# :type list)
422   ;; a list of the names of functions this VOP is a translation of and
423   ;; the policy that allows this translation to be done. :FAST is a
424   ;; safe default, since it isn't a safe policy.
425   (translate () :type list)
426   (ltn-policy :fast :type ltn-policy)
427   ;; stuff used by life analysis
428   (save-p nil :type (member t nil :compute-only :force-to-stack))
429   ;; info about how to emit MOVE-ARG VOPs for the &MORE operand in
430   ;; call/return VOPs
431   (move-args nil :type (member nil :local-call :full-call :known-return)))
432 (defprinter (vop-parse)
433   name
434   (inherits :test inherits)
435   args
436   results
437   temps
438   (more-args :test more-args)
439   (more-results :test more-results)
440   (conditional-p :test conditional-p)
441   ignores
442   arg-types
443   result-types
444   cost
445   body
446   (variant :test variant)
447   (variant-vars :test variant-vars)
448   (info-args :test info-args)
449   (note :test note)
450   effects
451   affected
452   translate
453   ltn-policy
454   (save-p :test save-p)
455   (move-args :test move-args))
456
457 ;;; An OPERAND-PARSE object contains stuff we need to know about an
458 ;;; operand or temporary at meta-compile time. Besides the obvious
459 ;;; stuff, we also store the names of per-operand temporaries here.
460 (def!struct (operand-parse
461              (:make-load-form-fun just-dump-it-normally)
462              #-sb-xc-host (:pure t))
463   ;; name of the operand (which we bind to the TN)
464   (name nil :type symbol)
465   ;; the way this operand is used:
466   (kind (missing-arg)
467         :type (member :argument :result :temporary
468                       :more-argument :more-result))
469   ;; If true, the name of an operand that this operand is targeted to.
470   ;; This is only meaningful in :ARGUMENT and :TEMPORARY operands.
471   (target nil :type (or symbol null))
472   ;; TEMP is a temporary that holds the TN-REF for this operand.
473   (temp (make-operand-parse-temp) :type symbol)
474   ;; the time that this operand is first live and the time at which it
475   ;; becomes dead again. These are TIME-SPECs, as returned by
476   ;; PARSE-TIME-SPEC.
477   born
478   dies
479   ;; a list of the names of the SCs that this operand is allowed into.
480   ;; If false, there is no restriction.
481   (scs nil :type list)
482   ;; Variable that is bound to the load TN allocated for this operand, or to
483   ;; NIL if no load-TN was allocated.
484   (load-tn (make-operand-parse-load-tn) :type symbol)
485   ;; an expression that tests whether to do automatic operand loading
486   (load t)
487   ;; In a wired or restricted temporary this is the SC the TN is to be
488   ;; packed in. Null otherwise.
489   (sc nil :type (or symbol null))
490   ;; If non-null, we are a temp wired to this offset in SC.
491   (offset nil :type (or unsigned-byte null)))
492 (defprinter (operand-parse)
493   name
494   kind
495   (target :test target)
496   born
497   dies
498   (scs :test scs)
499   (load :test load)
500   (sc :test sc)
501   (offset :test offset))
502 \f
503 ;;;; miscellaneous utilities
504
505 ;;; Find the operand or temporary with the specifed Name in the VOP
506 ;;; Parse. If there is no such operand, signal an error. Also error if
507 ;;; the operand kind isn't one of the specified Kinds. If Error-P is
508 ;;; NIL, just return NIL if there is no such operand.
509 (defun find-operand (name parse &optional
510                           (kinds '(:argument :result :temporary))
511                           (error-p t))
512   (declare (symbol name) (type vop-parse parse) (list kinds))
513   (let ((found (find name (vop-parse-operands parse)
514                      :key #'operand-parse-name)))
515     (if found
516         (unless (member (operand-parse-kind found) kinds)
517           (error "Operand ~S isn't one of these kinds: ~S." name kinds))
518         (when error-p
519           (error "~S is not an operand to ~S." name (vop-parse-name parse))))
520     found))
521
522 ;;; Get the VOP-PARSE structure for NAME or die trying. For all
523 ;;; meta-compile time uses, the VOP-PARSE should be used instead of
524 ;;; the VOP-INFO.
525 (defun vop-parse-or-lose (name)
526   (the vop-parse
527        (or (gethash name *backend-parsed-vops*)
528            (error "~S is not the name of a defined VOP." name))))
529
530 ;;; Return a list of LET-forms to parse a TN-REF list into the temps
531 ;;; specified by the operand-parse structures. MORE-OPERAND is the
532 ;;; OPERAND-PARSE describing any more operand, or NIL if none. REFS is
533 ;;; an expression that evaluates into the first TN-REF.
534 (defun access-operands (operands more-operand refs)
535   (declare (list operands))
536   (collect ((res))
537     (let ((prev refs))
538       (dolist (op operands)
539         (let ((n-ref (operand-parse-temp op)))
540           (res `(,n-ref ,prev))
541           (setq prev `(tn-ref-across ,n-ref))))
542
543       (when more-operand
544         (res `(,(operand-parse-name more-operand) ,prev))))
545     (res)))
546
547 ;;; This is used with ACCESS-OPERANDS to prevent warnings for TN-REF
548 ;;; temps not used by some particular function. It returns the name of
549 ;;; the last operand, or NIL if OPERANDS is NIL.
550 (defun ignore-unreferenced-temps (operands)
551   (when operands
552     (operand-parse-temp (car (last operands)))))
553
554 ;;; Grab an arg out of a VOP spec, checking the type and syntax and stuff.
555 (defun vop-spec-arg (spec type &optional (n 1) (last t))
556   (let ((len (length spec)))
557     (when (<= len n)
558       (error "~:R argument missing: ~S" n spec))
559     (when (and last (> len (1+ n)))
560       (error "extra junk at end of ~S" spec))
561     (let ((thing (elt spec n)))
562       (unless (typep thing type)
563         (error "~:R argument is not a ~S: ~S" n type spec))
564       thing)))
565 \f
566 ;;;; time specs
567
568 ;;; Return a time spec describing a time during the evaluation of a
569 ;;; VOP, used to delimit operand and temporary lifetimes. The
570 ;;; representation is a cons whose CAR is the number of the evaluation
571 ;;; phase and the CDR is the sub-phase. The sub-phase is 0 in the
572 ;;; :LOAD and :SAVE phases.
573 (defun parse-time-spec (spec)
574   (let ((dspec (if (atom spec) (list spec 0) spec)))
575     (unless (and (= (length dspec) 2)
576                  (typep (second dspec) 'unsigned-byte))
577       (error "malformed time specifier: ~S" spec))
578
579     (cons (case (first dspec)
580             (:load 0)
581             (:argument 1)
582             (:eval 2)
583             (:result 3)
584             (:save 4)
585             (t
586              (error "unknown phase in time specifier: ~S" spec)))
587           (second dspec))))
588
589 ;;; Return true if the time spec X is the same or later time than Y.
590 (defun time-spec-order (x y)
591   (or (> (car x) (car y))
592       (and (= (car x) (car y))
593            (>= (cdr x) (cdr y)))))
594 \f
595 ;;;; generation of emit functions
596
597 (defun compute-temporaries-description (parse)
598   (let ((temps (vop-parse-temps parse))
599         (element-type '(unsigned-byte 16)))
600     (when temps
601       (let ((results (make-specializable-array
602                       (length temps)
603                       :element-type element-type))
604             (index 0))
605         (dolist (temp temps)
606           (declare (type operand-parse temp))
607           (let ((sc (operand-parse-sc temp))
608                 (offset (operand-parse-offset temp)))
609             (aver sc)
610             (setf (aref results index)
611                   (if offset
612                       (+ (ash offset (1+ sc-bits))
613                          (ash (meta-sc-number-or-lose sc) 1)
614                          1)
615                       (ash (meta-sc-number-or-lose sc) 1))))
616           (incf index))
617         ;; KLUDGE: As in the other COERCEs wrapped around with
618         ;; MAKE-SPECIALIZABLE-ARRAY results in COMPUTE-REF-ORDERING,
619         ;; this coercion could be removed by a sufficiently smart
620         ;; compiler, but I dunno whether Python is that smart. It
621         ;; would be good to check this and help it if it's not smart
622         ;; enough to remove it for itself. However, it's probably not
623         ;; urgent, since the overhead of an extra no-op conversion is
624         ;; unlikely to be large compared to consing and corresponding
625         ;; GC. -- WHN ca. 19990701
626         `(coerce ,results '(specializable-vector ,element-type))))))
627
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)))
633          (index 0))
634     (collect ((refs) (targets))
635       (dolist (op (vop-parse-operands parse))
636         (when (operand-parse-target op)
637           (unless (member (operand-parse-kind op) '(:argument :temporary))
638             (error "cannot target a ~S operand: ~S" (operand-parse-kind op)
639                    (operand-parse-name op)))
640           (let ((target (find-operand (operand-parse-target op) parse
641                                       '(:temporary :result))))
642             ;; KLUDGE: These formulas must be consistent with those in
643             ;; %EMIT-GENERIC-VOP, and this is currently maintained by
644             ;; hand. -- WHN 2002-01-30, paraphrasing APD
645             (targets (+ (* index max-vop-tn-refs)
646                         (ecase (operand-parse-kind target)
647                           (:result
648                            (+ (position-or-lose target
649                                                 (vop-parse-results parse))
650                               num-args))
651                           (:temporary
652                            (+ (* (position-or-lose target
653                                                    (vop-parse-temps parse))
654                                  2)
655                               1
656                               num-args
657                               num-results)))))))
658         (let ((born (operand-parse-born op))
659               (dies (operand-parse-dies op)))
660           (ecase (operand-parse-kind op)
661             (:argument
662              (refs (cons (cons dies nil) index)))
663             (:more-argument
664              (refs (cons (cons dies nil) index)))
665             (:result
666              (refs (cons (cons born t) index)))
667             (:more-result
668              (refs (cons (cons born t) index)))
669             (:temporary
670              (refs (cons (cons dies nil) index))
671              (incf index)
672              (refs (cons (cons born t) index))))
673           (incf index)))
674       (let* ((sorted (stable-sort (refs)
675                                   (lambda (x y)
676                                     (let ((x-time (car x))
677                                           (y-time (car y)))
678                                       (if (time-spec-order x-time y-time)
679                                           (if (time-spec-order y-time x-time)
680                                               (and (not (cdr x)) (cdr y))
681                                               nil)
682                                           t)))
683                                   :key #'car))
684              ;; :REF-ORDERING element type
685              ;;
686              ;; KLUDGE: was (MOD #.MAX-VOP-TN-REFS), which is still right
687              (oe-type '(unsigned-byte 8))
688              ;; :TARGETS element-type
689              ;;
690              ;; KLUDGE: was (MOD #.(* MAX-VOP-TN-REFS 2)), which does
691              ;; not correspond to the definition in
692              ;; src/compiler/vop.lisp.
693              (te-type '(unsigned-byte 16))
694              (ordering (make-specializable-array
695                         (length sorted)
696                         :element-type oe-type)))
697         (let ((index 0))
698           (dolist (ref sorted)
699             (setf (aref ordering index) (cdr ref))
700             (incf index)))
701         `(:num-args ,num-args
702           :num-results ,num-results
703           ;; KLUDGE: The (COERCE .. (SPECIALIZABLE-VECTOR ..)) wrapper
704           ;; here around the result returned by
705           ;; MAKE-SPECIALIZABLE-ARRAY above was of course added to
706           ;; help with cross-compilation. "A sufficiently smart
707           ;; compiler" should be able to optimize all this away in the
708           ;; final target Lisp, leaving a single MAKE-ARRAY with no
709           ;; subsequent coercion. However, I don't know whether Python
710           ;; is that smart. (Can it figure out the return type of
711           ;; MAKE-ARRAY? Does it know that COERCE can be optimized
712           ;; away if the input type is known to be the same as the
713           ;; COERCEd-to type?) At some point it would be good to test
714           ;; to see whether this construct is in fact causing run-time
715           ;; overhead, and fix it if so. (Some declarations of the
716           ;; types returned by MAKE-ARRAY might be enough to fix it.)
717           ;; However, it's probably not urgent to fix this, since it's
718           ;; hard to imagine that any overhead caused by calling
719           ;; COERCE and letting it decide to bail out could be large
720           ;; compared to the cost of consing and GCing the vectors in
721           ;; the first place. -- WHN ca. 19990701
722           :ref-ordering (coerce ',ordering
723                                 '(specializable-vector ,oe-type))
724           ,@(when (targets)
725               `(:targets (coerce ',(targets)
726                                  '(specializable-vector ,te-type)))))))))
727
728 (defun make-emit-function-and-friends (parse)
729   `(:emit-function #'emit-generic-vop
730     :temps ,(compute-temporaries-description parse)
731     ,@(compute-ref-ordering parse)))
732 \f
733 ;;;; generator functions
734
735 ;;; Return an alist that translates from lists of SCs we can load OP
736 ;;; from to the move function used for loading those SCs. We quietly
737 ;;; ignore restrictions to :non-packed (constant) and :unbounded SCs,
738 ;;; since we don't load into those SCs.
739 (defun find-move-funs (op load-p)
740   (collect ((funs))
741     (dolist (sc-name (operand-parse-scs op))
742       (let* ((sc (meta-sc-or-lose sc-name))
743              (scn (sc-number sc))
744              (load-scs (append (when load-p
745                                  (sc-constant-scs sc))
746                                (sc-alternate-scs sc))))
747         (cond
748          (load-scs
749           (dolist (alt load-scs)
750             (unless (member (sc-name alt) (operand-parse-scs op) :test #'eq)
751               (let* ((altn (sc-number alt))
752                      (name (if load-p
753                                (svref (sc-move-funs sc) altn)
754                                (svref (sc-move-funs alt) scn)))
755                      (found (or (assoc alt (funs) :test #'member)
756                                 (rassoc name (funs)))))
757                 (unless name
758                   (error "no move function defined to ~:[save~;load~] SC ~S ~
759                           ~:[to~;from~] from SC ~S"
760                          load-p sc-name load-p (sc-name alt)))
761
762                 (cond (found
763                        (unless (eq (cdr found) name)
764                          (error "can't tell whether to ~:[save~;load~]~@
765                                  with ~S or ~S when operand is in SC ~S"
766                                 load-p name (cdr found) (sc-name alt)))
767                        (pushnew alt (car found)))
768                       (t
769                        (funs (cons (list alt) name))))))))
770          ((member (sb-kind (sc-sb sc)) '(:non-packed :unbounded)))
771          (t
772           (error "SC ~S has no alternate~:[~; or constant~] SCs, yet it is~@
773                   mentioned in the restriction for operand ~S"
774                  sc-name load-p (operand-parse-name op))))))
775     (funs)))
776
777 ;;; Return a form to load/save the specified operand when it has a
778 ;;; load TN. For any given SC that we can load from, there must be a
779 ;;; unique load function. If all SCs we can load from have the same
780 ;;; move function, then we just call that when there is a load TN. If
781 ;;; there are multiple possible move functions, then we dispatch off
782 ;;; of the operand TN's type to see which move function to use.
783 (defun call-move-fun (parse op load-p)
784   (let ((funs (find-move-funs op load-p))
785         (load-tn (operand-parse-load-tn op)))
786     (if funs
787         (let* ((tn `(tn-ref-tn ,(operand-parse-temp op)))
788                (n-vop (or (vop-parse-vop-var parse)
789                           (setf (vop-parse-vop-var parse) '.vop.)))
790                (form (if (rest funs)
791                          `(sc-case ,tn
792                             ,@(mapcar (lambda (x)
793                                         `(,(mapcar #'sc-name (car x))
794                                           ,(if load-p
795                                                `(,(cdr x) ,n-vop ,tn
796                                                  ,load-tn)
797                                                `(,(cdr x) ,n-vop ,load-tn
798                                                  ,tn))))
799                                       funs))
800                          (if load-p
801                              `(,(cdr (first funs)) ,n-vop ,tn ,load-tn)
802                              `(,(cdr (first funs)) ,n-vop ,load-tn ,tn)))))
803           (if (eq (operand-parse-load op) t)
804               `(when ,load-tn ,form)
805               `(when (eq ,load-tn ,(operand-parse-name op))
806                  ,form)))
807         `(when ,load-tn
808            (error "load TN allocated, but no move function?~@
809                    VM definition is inconsistent, recompile and try again.")))))
810
811 ;;; Return the TN that we should bind to the operand's var in the
812 ;;; generator body. In general, this involves evaluating the :LOAD-IF
813 ;;; test expression.
814 (defun decide-to-load (parse op)
815   (let ((load (operand-parse-load op))
816         (load-tn (operand-parse-load-tn op))
817         (temp (operand-parse-temp op)))
818     (if (eq load t)
819         `(or ,load-tn (tn-ref-tn ,temp))
820         (collect ((binds)
821                   (ignores))
822           (dolist (x (vop-parse-operands parse))
823             (when (member (operand-parse-kind x) '(:argument :result))
824               (let ((name (operand-parse-name x)))
825                 (binds `(,name (tn-ref-tn ,(operand-parse-temp x))))
826                 (ignores name))))
827           `(if (and ,load-tn
828                     (let ,(binds)
829                       (declare (ignorable ,@(ignores)))
830                       ,load))
831                ,load-tn
832                (tn-ref-tn ,temp))))))
833
834 ;;; Make a lambda that parses the VOP TN-REFS, does automatic operand
835 ;;; loading, and runs the appropriate code generator.
836 (defun make-generator-function (parse)
837   (declare (type vop-parse parse))
838   (let ((n-vop (vop-parse-vop-var parse))
839         (operands (vop-parse-operands parse))
840         (n-info (gensym)) (n-variant (gensym)))
841     (collect ((binds)
842               (loads)
843               (saves))
844       (dolist (op operands)
845         (ecase (operand-parse-kind op)
846           ((:argument :result)
847            (let ((temp (operand-parse-temp op))
848                  (name (operand-parse-name op)))
849              (cond ((and (operand-parse-load op) (operand-parse-scs op))
850                     (binds `(,(operand-parse-load-tn op)
851                              (tn-ref-load-tn ,temp)))
852                     (binds `(,name ,(decide-to-load parse op)))
853                     (if (eq (operand-parse-kind op) :argument)
854                         (loads (call-move-fun parse op t))
855                         (saves (call-move-fun parse op nil))))
856                    (t
857                     (binds `(,name (tn-ref-tn ,temp)))))))
858           (:temporary
859            (binds `(,(operand-parse-name op)
860                     (tn-ref-tn ,(operand-parse-temp op)))))
861           ((:more-argument :more-result))))
862
863       `(lambda (,n-vop)
864          (let* (,@(access-operands (vop-parse-args parse)
865                                    (vop-parse-more-args parse)
866                                    `(vop-args ,n-vop))
867                   ,@(access-operands (vop-parse-results parse)
868                                      (vop-parse-more-results parse)
869                                      `(vop-results ,n-vop))
870                   ,@(access-operands (vop-parse-temps parse) nil
871                                      `(vop-temps ,n-vop))
872                   ,@(when (vop-parse-info-args parse)
873                       `((,n-info (vop-codegen-info ,n-vop))
874                         ,@(mapcar (lambda (x) `(,x (pop ,n-info)))
875                                   (vop-parse-info-args parse))))
876                   ,@(when (vop-parse-variant-vars parse)
877                       `((,n-variant (vop-info-variant (vop-info ,n-vop)))
878                         ,@(mapcar (lambda (x) `(,x (pop ,n-variant)))
879                                   (vop-parse-variant-vars parse))))
880                   ,@(when (vop-parse-node-var parse)
881                       `((,(vop-parse-node-var parse) (vop-node ,n-vop))))
882                   ,@(binds))
883            (declare (ignore ,@(vop-parse-ignores parse)))
884            ,@(loads)
885            (sb!assem:assemble (*code-segment* ,n-vop)
886                               ,@(vop-parse-body parse))
887            ,@(saves))))))
888 \f
889 (defvar *parse-vop-operand-count*)
890 (defun make-operand-parse-temp ()
891   (without-package-locks
892    (intern (format nil "OPERAND-PARSE-TEMP-~D" *parse-vop-operand-count*)
893            (symbol-package '*parse-vop-operand-count*))))
894 (defun make-operand-parse-load-tn ()
895   (without-package-locks
896    (intern (format nil "OPERAND-PARSE-LOAD-TN-~D" *parse-vop-operand-count*)
897            (symbol-package '*parse-vop-operand-count*))))
898
899 ;;; Given a list of operand specifications as given to DEFINE-VOP,
900 ;;; return a list of OPERAND-PARSE structures describing the fixed
901 ;;; operands, and a single OPERAND-PARSE describing any more operand.
902 ;;; If we are inheriting a VOP, we default attributes to the inherited
903 ;;; operand of the same name.
904 (defun !parse-vop-operands (parse specs kind)
905   (declare (list specs)
906            (type (member :argument :result) kind))
907   (let ((num -1)
908         (more nil))
909     (collect ((operands))
910       (dolist (spec specs)
911         (unless (and (consp spec) (symbolp (first spec)) (oddp (length spec)))
912           (error "malformed operand specifier: ~S" spec))
913         (when more
914           (error "The MORE operand isn't the last operand: ~S" specs))
915         (incf *parse-vop-operand-count*)
916         (let* ((name (first spec))
917                (old (if (vop-parse-inherits parse)
918                         (find-operand name
919                                       (vop-parse-or-lose
920                                        (vop-parse-inherits parse))
921                                       (list kind)
922                                       nil)
923                         nil))
924                (res (if old
925                         (make-operand-parse
926                          :name name
927                          :kind kind
928                          :target (operand-parse-target old)
929                          :born (operand-parse-born old)
930                          :dies (operand-parse-dies old)
931                          :scs (operand-parse-scs old)
932                          :load-tn (operand-parse-load-tn old)
933                          :load (operand-parse-load old))
934                         (ecase kind
935                           (:argument
936                            (make-operand-parse
937                             :name (first spec)
938                             :kind :argument
939                             :born (parse-time-spec :load)
940                             :dies (parse-time-spec `(:argument ,(incf num)))))
941                           (:result
942                            (make-operand-parse
943                             :name (first spec)
944                             :kind :result
945                             :born (parse-time-spec `(:result ,(incf num)))
946                             :dies (parse-time-spec :save)))))))
947           (do ((key (rest spec) (cddr key)))
948               ((null key))
949             (let ((value (second key)))
950               (case (first key)
951                 (:scs
952                  (aver (typep value 'list))
953                  (setf (operand-parse-scs res) (remove-duplicates value)))
954                 (:load-tn
955                  (aver (typep value 'symbol))
956                  (setf (operand-parse-load-tn res) value))
957                 (:load-if
958                  (setf (operand-parse-load res) value))
959                 (:more
960                  (aver (typep value 'boolean))
961                  (setf (operand-parse-kind res)
962                        (if (eq kind :argument) :more-argument :more-result))
963                  (setf (operand-parse-load res) nil)
964                  (setq more res))
965                 (:target
966                  (aver (typep value 'symbol))
967                  (setf (operand-parse-target res) value))
968                 (:from
969                  (unless (eq kind :result)
970                    (error "can only specify :FROM in a result: ~S" spec))
971                  (setf (operand-parse-born res) (parse-time-spec value)))
972                 (:to
973                  (unless (eq kind :argument)
974                    (error "can only specify :TO in an argument: ~S" spec))
975                  (setf (operand-parse-dies res) (parse-time-spec value)))
976                 (t
977                  (error "unknown keyword in operand specifier: ~S" spec)))))
978
979           (cond ((not more)
980                  (operands res))
981                 ((operand-parse-target more)
982                  (error "cannot specify :TARGET in a :MORE operand"))
983                 ((operand-parse-load more)
984                  (error "cannot specify :LOAD-IF in a :MORE operand")))))
985       (values (the list (operands)) more))))
986 \f
987 ;;; Parse a temporary specification, putting the OPERAND-PARSE
988 ;;; structures in the PARSE structure.
989 (defun parse-temporary (spec parse)
990   (declare (list spec)
991            (type vop-parse parse))
992   (let ((len (length spec)))
993     (unless (>= len 2)
994       (error "malformed temporary spec: ~S" spec))
995     (unless (listp (second spec))
996       (error "malformed options list: ~S" (second spec)))
997     (unless (evenp (length (second spec)))
998       (error "odd number of arguments in keyword options: ~S" spec))
999     (unless (consp (cddr spec))
1000       (warn "temporary spec allocates no temps:~%  ~S" spec))
1001     (dolist (name (cddr spec))
1002       (unless (symbolp name)
1003         (error "bad temporary name: ~S" name))
1004       (incf *parse-vop-operand-count*)
1005       (let ((res (make-operand-parse :name name
1006                                      :kind :temporary
1007                                      :born (parse-time-spec :load)
1008                                      :dies (parse-time-spec :save))))
1009         (do ((opt (second spec) (cddr opt)))
1010             ((null opt))
1011           (case (first opt)
1012             (:target
1013              (setf (operand-parse-target res)
1014                    (vop-spec-arg opt 'symbol 1 nil)))
1015             (:sc
1016              (setf (operand-parse-sc res)
1017                    (vop-spec-arg opt 'symbol 1 nil)))
1018             (:offset
1019              (let ((offset (eval (second opt))))
1020                (aver (typep offset 'unsigned-byte))
1021                (setf (operand-parse-offset res) offset)))
1022             (:from
1023              (setf (operand-parse-born res) (parse-time-spec (second opt))))
1024             (:to
1025              (setf (operand-parse-dies res) (parse-time-spec (second opt))))
1026             ;; backward compatibility...
1027             (:scs
1028              (let ((scs (vop-spec-arg opt 'list 1 nil)))
1029                (unless (= (length scs) 1)
1030                  (error "must specify exactly one SC for a temporary"))
1031                (setf (operand-parse-sc res) (first scs))))
1032             (:type)
1033             (t
1034              (error "unknown temporary option: ~S" opt))))
1035
1036         (unless (and (time-spec-order (operand-parse-dies res)
1037                                       (operand-parse-born res))
1038                      (not (time-spec-order (operand-parse-born res)
1039                                            (operand-parse-dies res))))
1040           (error "Temporary lifetime doesn't begin before it ends: ~S" spec))
1041
1042         (unless (operand-parse-sc res)
1043           (error "must specify :SC for all temporaries: ~S" spec))
1044
1045         (setf (vop-parse-temps parse)
1046               (cons res
1047                     (remove name (vop-parse-temps parse)
1048                             :key #'operand-parse-name))))))
1049   (values))
1050 \f
1051 (defun compute-parse-vop-operand-count (parse)
1052   (declare (type vop-parse parse))
1053   (labels ((compute-count-aux (parse)
1054              (declare (type vop-parse parse))
1055              (if (null (vop-parse-inherits parse))
1056                  (length (vop-parse-operands parse))
1057                  (+ (length (vop-parse-operands parse))
1058                     (compute-count-aux
1059                      (vop-parse-or-lose (vop-parse-inherits parse)))))))
1060     (if (null (vop-parse-inherits parse))
1061         0
1062         (compute-count-aux (vop-parse-or-lose (vop-parse-inherits parse))))))
1063
1064 ;;; the top level parse function: clobber PARSE to represent the
1065 ;;; specified options.
1066 (defun parse-define-vop (parse specs)
1067   (declare (type vop-parse parse) (list specs))
1068   (let ((*parse-vop-operand-count* (compute-parse-vop-operand-count parse)))
1069     (dolist (spec specs)
1070       (unless (consp spec)
1071         (error "malformed option specification: ~S" spec))
1072       (case (first spec)
1073         (:args
1074          (multiple-value-bind (fixed more)
1075              (!parse-vop-operands parse (rest spec) :argument)
1076            (setf (vop-parse-args parse) fixed)
1077            (setf (vop-parse-more-args parse) more)))
1078         (:results
1079          (multiple-value-bind (fixed more)
1080              (!parse-vop-operands parse (rest spec) :result)
1081            (setf (vop-parse-results parse) fixed)
1082            (setf (vop-parse-more-results parse) more))
1083          (setf (vop-parse-conditional-p parse) nil))
1084         (:conditional
1085          (setf (vop-parse-result-types parse) ())
1086          (setf (vop-parse-results parse) ())
1087          (setf (vop-parse-more-results parse) nil)
1088          (setf (vop-parse-conditional-p parse) (or (rest spec) t)))
1089         (:temporary
1090          (parse-temporary spec parse))
1091         (:generator
1092             (setf (vop-parse-cost parse)
1093                   (vop-spec-arg spec 'unsigned-byte 1 nil))
1094           (setf (vop-parse-body parse) (cddr spec)))
1095         (:effects
1096          (setf (vop-parse-effects parse) (rest spec)))
1097         (:affected
1098          (setf (vop-parse-affected parse) (rest spec)))
1099         (:info
1100          (setf (vop-parse-info-args parse) (rest spec)))
1101         (:ignore
1102          (setf (vop-parse-ignores parse) (rest spec)))
1103         (:variant
1104          (setf (vop-parse-variant parse) (rest spec)))
1105         (:variant-vars
1106          (let ((vars (rest spec)))
1107            (setf (vop-parse-variant-vars parse) vars)
1108            (setf (vop-parse-variant parse)
1109                  (make-list (length vars) :initial-element nil))))
1110         (:variant-cost
1111          (setf (vop-parse-cost parse) (vop-spec-arg spec 'unsigned-byte)))
1112         (:vop-var
1113          (setf (vop-parse-vop-var parse) (vop-spec-arg spec 'symbol)))
1114         (:move-args
1115          (setf (vop-parse-move-args parse)
1116                (vop-spec-arg spec '(member nil :local-call :full-call
1117                                     :known-return))))
1118         (:node-var
1119          (setf (vop-parse-node-var parse) (vop-spec-arg spec 'symbol)))
1120         (:note
1121          (setf (vop-parse-note parse) (vop-spec-arg spec '(or string null))))
1122         (:arg-types
1123          (setf (vop-parse-arg-types parse)
1124                (!parse-vop-operand-types (rest spec) t)))
1125         (:result-types
1126          (setf (vop-parse-result-types parse)
1127                (!parse-vop-operand-types (rest spec) nil)))
1128         (:translate
1129          (setf (vop-parse-translate parse) (rest spec)))
1130         (:guard
1131          (setf (vop-parse-guard parse) (vop-spec-arg spec t)))
1132         ;; FIXME: :LTN-POLICY would be a better name for this. It
1133         ;; would probably be good to leave it unchanged for a while,
1134         ;; though, at least until the first port to some other
1135         ;; architecture, since the renaming would be a change to the
1136         ;; interface between
1137         (:policy
1138          (setf (vop-parse-ltn-policy parse)
1139                (vop-spec-arg spec 'ltn-policy)))
1140         (:save-p
1141          (setf (vop-parse-save-p parse)
1142                (vop-spec-arg spec
1143                              '(member t nil :compute-only :force-to-stack))))
1144         (t
1145          (error "unknown option specifier: ~S" (first spec)))))
1146     (values)))
1147 \f
1148 ;;;; making costs and restrictions
1149
1150 ;;; Given an operand, returns two values:
1151 ;;; 1. A SC-vector of the cost for the operand being in that SC,
1152 ;;;    including both the costs for move functions and coercion VOPs.
1153 ;;; 2. A SC-vector holding the SC that we load into, for any SC
1154 ;;;    that we can directly load from.
1155 ;;;
1156 ;;; In both vectors, unused entries are NIL. LOAD-P specifies the
1157 ;;; direction: if true, we are loading, if false we are saving.
1158 (defun compute-loading-costs (op load-p)
1159   (declare (type operand-parse op))
1160   (let ((scs (operand-parse-scs op))
1161         (costs (make-array sc-number-limit :initial-element nil))
1162         (load-scs (make-array sc-number-limit :initial-element nil)))
1163     (dolist (sc-name scs)
1164       (let* ((load-sc (meta-sc-or-lose sc-name))
1165              (load-scn (sc-number load-sc)))
1166         (setf (svref costs load-scn) 0)
1167         (setf (svref load-scs load-scn) t)
1168         (dolist (op-sc (append (when load-p
1169                                  (sc-constant-scs load-sc))
1170                                (sc-alternate-scs load-sc)))
1171           (let* ((op-scn (sc-number op-sc))
1172                  (load (if load-p
1173                            (aref (sc-load-costs load-sc) op-scn)
1174                            (aref (sc-load-costs op-sc) load-scn))))
1175             (unless load
1176               (error "no move function defined to move ~:[from~;to~] SC ~
1177                       ~S~%~:[to~;from~] alternate or constant SC ~S"
1178                      load-p sc-name load-p (sc-name op-sc)))
1179
1180             (let ((op-cost (svref costs op-scn)))
1181               (when (or (not op-cost) (< load op-cost))
1182                 (setf (svref costs op-scn) load)))
1183
1184             (let ((op-load (svref load-scs op-scn)))
1185               (unless (eq op-load t)
1186                 (pushnew load-scn (svref load-scs op-scn))))))
1187
1188         (dotimes (i sc-number-limit)
1189           (unless (svref costs i)
1190             (let ((op-sc (svref *backend-meta-sc-numbers* i)))
1191               (when op-sc
1192                 (let ((cost (if load-p
1193                                 (svref (sc-move-costs load-sc) i)
1194                                 (svref (sc-move-costs op-sc) load-scn))))
1195                   (when cost
1196                     (setf (svref costs i) cost)))))))))
1197
1198     (values costs load-scs)))
1199
1200 (defparameter *no-costs*
1201   (make-array sc-number-limit :initial-element 0))
1202
1203 (defparameter *no-loads*
1204   (make-array sc-number-limit :initial-element t))
1205
1206 ;;; Pick off the case of operands with no restrictions.
1207 (defun compute-loading-costs-if-any (op load-p)
1208   (declare (type operand-parse op))
1209   (if (operand-parse-scs op)
1210       (compute-loading-costs op load-p)
1211       (values *no-costs* *no-loads*)))
1212
1213 (defun compute-costs-and-restrictions-list (ops load-p)
1214   (declare (list ops))
1215   (collect ((costs)
1216             (scs))
1217     (dolist (op ops)
1218       (multiple-value-bind (costs scs) (compute-loading-costs-if-any op load-p)
1219         (costs costs)
1220         (scs scs)))
1221     (values (costs) (scs))))
1222
1223 (defun make-costs-and-restrictions (parse)
1224   (multiple-value-bind (arg-costs arg-scs)
1225       (compute-costs-and-restrictions-list (vop-parse-args parse) t)
1226     (multiple-value-bind (result-costs result-scs)
1227         (compute-costs-and-restrictions-list (vop-parse-results parse) nil)
1228       `(
1229         :cost ,(vop-parse-cost parse)
1230
1231         :arg-costs ',arg-costs
1232         :arg-load-scs ',arg-scs
1233         :result-costs ',result-costs
1234         :result-load-scs ',result-scs
1235
1236         :more-arg-costs
1237         ',(if (vop-parse-more-args parse)
1238               (compute-loading-costs-if-any (vop-parse-more-args parse) t)
1239               nil)
1240
1241         :more-result-costs
1242         ',(if (vop-parse-more-results parse)
1243               (compute-loading-costs-if-any (vop-parse-more-results parse) nil)
1244               nil)))))
1245 \f
1246 ;;;; operand checking and stuff
1247
1248 ;;; Given a list of arg/result restrictions, check for valid syntax
1249 ;;; and convert to canonical form.
1250 (defun !parse-vop-operand-types (specs args-p)
1251   (declare (list specs))
1252   (labels ((parse-operand-type (spec)
1253              (cond ((eq spec '*) spec)
1254                    ((symbolp spec)
1255                     (let ((alias (gethash spec
1256                                           *backend-primitive-type-aliases*)))
1257                       (if alias
1258                           (parse-operand-type alias)
1259                           `(:or ,spec))))
1260                    ((atom spec)
1261                     (error "bad thing to be a operand type: ~S" spec))
1262                    (t
1263                     (case (first spec)
1264                       (:or
1265                        (collect ((results))
1266                          (results :or)
1267                          (dolist (item (cdr spec))
1268                            (unless (symbolp item)
1269                              (error "bad PRIMITIVE-TYPE name in ~S: ~S"
1270                                     spec item))
1271                            (let ((alias
1272                                   (gethash item
1273                                            *backend-primitive-type-aliases*)))
1274                              (if alias
1275                                  (let ((alias (parse-operand-type alias)))
1276                                    (unless (eq (car alias) :or)
1277                                      (error "can't include primitive-type ~
1278                                              alias ~S in an :OR restriction: ~S"
1279                                             item spec))
1280                                    (dolist (x (cdr alias))
1281                                      (results x)))
1282                                  (results item))))
1283                          (remove-duplicates (results)
1284                                             :test #'eq
1285                                             :start 1)))
1286                       (:constant
1287                        (unless args-p
1288                          (error "can't :CONSTANT for a result"))
1289                        (unless (= (length spec) 2)
1290                          (error "bad :CONSTANT argument type spec: ~S" spec))
1291                        spec)
1292                       (t
1293                        (error "bad thing to be a operand type: ~S" spec)))))))
1294     (mapcar #'parse-operand-type specs)))
1295
1296 ;;; Check the consistency of OP's SC restrictions with the specified
1297 ;;; primitive-type restriction. :CONSTANT operands have already been
1298 ;;; filtered out, so only :OR and * restrictions are left.
1299 ;;;
1300 ;;; We check that every representation allowed by the type can be
1301 ;;; directly loaded into some SC in the restriction, and that the type
1302 ;;; allows every SC in the restriction. With *, we require that T
1303 ;;; satisfy the first test, and omit the second.
1304 (defun check-operand-type-scs (parse op type load-p)
1305   (declare (type vop-parse parse) (type operand-parse op))
1306   (let ((ptypes (if (eq type '*) (list t) (rest type)))
1307         (scs (operand-parse-scs op)))
1308     (when scs
1309       (multiple-value-bind (costs load-scs) (compute-loading-costs op load-p)
1310         (declare (ignore costs))
1311         (dolist (ptype ptypes)
1312           (unless (dolist (rep (primitive-type-scs
1313                                 (meta-primitive-type-or-lose ptype))
1314                                nil)
1315                     (when (svref load-scs rep) (return t)))
1316             (error "In the ~A ~:[result~;argument~] to VOP ~S,~@
1317                     none of the SCs allowed by the operand type ~S can ~
1318                     directly be loaded~@
1319                     into any of the restriction's SCs:~%  ~S~:[~;~@
1320                     [* type operand must allow T's SCs.]~]"
1321                    (operand-parse-name op) load-p (vop-parse-name parse)
1322                    ptype
1323                    scs (eq type '*)))))
1324
1325       (dolist (sc scs)
1326         (unless (or (eq type '*)
1327                     (dolist (ptype ptypes nil)
1328                       (when (meta-sc-allowed-by-primitive-type
1329                              (meta-sc-or-lose sc)
1330                              (meta-primitive-type-or-lose ptype))
1331                         (return t))))
1332           (warn "~:[Result~;Argument~] ~A to VOP ~S~@
1333                  has SC restriction ~S which is ~
1334                  not allowed by the operand type:~%  ~S"
1335                 load-p (operand-parse-name op) (vop-parse-name parse)
1336                 sc type)))))
1337
1338   (values))
1339
1340 ;;; If the operand types are specified, then check the number specified
1341 ;;; against the number of defined operands.
1342 (defun check-operand-types (parse ops more-op types load-p)
1343   (declare (type vop-parse parse) (list ops)
1344            (type (or list (member :unspecified)) types)
1345            (type (or operand-parse null) more-op))
1346   (unless (eq types :unspecified)
1347     (let ((num (+ (length ops) (if more-op 1 0))))
1348       (unless (= (count-if-not (lambda (x)
1349                                  (and (consp x)
1350                                       (eq (car x) :constant)))
1351                                types)
1352                  num)
1353         (error "expected ~W ~:[result~;argument~] type~P: ~S"
1354                num load-p types num)))
1355
1356     (when more-op
1357       (let ((mtype (car (last types))))
1358         (when (and (consp mtype) (eq (first mtype) :constant))
1359           (error "can't use :CONSTANT on VOP more args")))))
1360
1361   (when (vop-parse-translate parse)
1362     (let ((types (specify-operand-types types ops more-op)))
1363       (mapc (lambda (x y)
1364               (check-operand-type-scs parse x y load-p))
1365             (if more-op (butlast ops) ops)
1366             (remove-if (lambda (x)
1367                          (and (consp x)
1368                               (eq (car x) ':constant)))
1369                        (if more-op (butlast types) types)))))
1370
1371   (values))
1372
1373 ;;; Compute stuff that can only be computed after we are done parsing
1374 ;;; everying. We set the VOP-PARSE-OPERANDS, and do various error checks.
1375 (defun !grovel-vop-operands (parse)
1376   (declare (type vop-parse parse))
1377
1378   (setf (vop-parse-operands parse)
1379         (append (vop-parse-args parse)
1380                 (if (vop-parse-more-args parse)
1381                     (list (vop-parse-more-args parse)))
1382                 (vop-parse-results parse)
1383                 (if (vop-parse-more-results parse)
1384                     (list (vop-parse-more-results parse)))
1385                 (vop-parse-temps parse)))
1386
1387   (check-operand-types parse
1388                        (vop-parse-args parse)
1389                        (vop-parse-more-args parse)
1390                        (vop-parse-arg-types parse)
1391                        t)
1392
1393   (check-operand-types parse
1394                        (vop-parse-results parse)
1395                        (vop-parse-more-results parse)
1396                        (vop-parse-result-types parse)
1397                        nil)
1398
1399   (values))
1400 \f
1401 ;;;; function translation stuff
1402
1403 ;;; Return forms to establish this VOP as a IR2 translation template
1404 ;;; for the :TRANSLATE functions specified in the VOP-PARSE. We also
1405 ;;; set the PREDICATE attribute for each translated function when the
1406 ;;; VOP is conditional, causing IR1 conversion to ensure that a call
1407 ;;; to the translated is always used in a predicate position.
1408 (defun !set-up-fun-translation (parse n-template)
1409   (declare (type vop-parse parse))
1410   (mapcar (lambda (name)
1411             `(let ((info (fun-info-or-lose ',name)))
1412                (setf (fun-info-templates info)
1413                      (adjoin-template ,n-template (fun-info-templates info)))
1414                ,@(when (vop-parse-conditional-p parse)
1415                    '((setf (fun-info-attributes info)
1416                            (attributes-union
1417                             (ir1-attributes predicate)
1418                             (fun-info-attributes info)))))))
1419           (vop-parse-translate parse)))
1420
1421 ;;; Return a form that can be evaluated to get the TEMPLATE operand type
1422 ;;; restriction from the given specification.
1423 (defun make-operand-type (type)
1424   (cond ((eq type '*) ''*)
1425         ((symbolp type)
1426          ``(:or ,(primitive-type-or-lose ',type)))
1427         (t
1428          (ecase (first type)
1429            (:or
1430             ``(:or ,,@(mapcar (lambda (type)
1431                                 `(primitive-type-or-lose ',type))
1432                               (rest type))))
1433            (:constant
1434             ``(:constant ,#'(lambda (x)
1435                               (typep x ',(second type)))
1436                          ,',(second type)))))))
1437
1438 (defun specify-operand-types (types ops more-ops)
1439   (if (eq types :unspecified)
1440       (make-list (+ (length ops) (if more-ops 1 0)) :initial-element '*)
1441       types))
1442
1443 ;;; Return a list of forms to use as &KEY args to MAKE-VOP-INFO for
1444 ;;; setting up the template argument and result types. Here we make an
1445 ;;; initial dummy TEMPLATE-TYPE, since it is awkward to compute the
1446 ;;; type until the template has been made.
1447 (defun make-vop-info-types (parse)
1448   (let* ((more-args (vop-parse-more-args parse))
1449          (all-args (specify-operand-types (vop-parse-arg-types parse)
1450                                           (vop-parse-args parse)
1451                                           more-args))
1452          (args (if more-args (butlast all-args) all-args))
1453          (more-arg (when more-args (car (last all-args))))
1454          (more-results (vop-parse-more-results parse))
1455          (all-results (specify-operand-types (vop-parse-result-types parse)
1456                                              (vop-parse-results parse)
1457                                              more-results))
1458          (results (if more-results (butlast all-results) all-results))
1459          (more-result (when more-results (car (last all-results))))
1460          (conditional (vop-parse-conditional-p parse)))
1461
1462     `(:type (specifier-type '(function () nil))
1463       :arg-types (list ,@(mapcar #'make-operand-type args))
1464       :more-args-type ,(when more-args (make-operand-type more-arg))
1465       :result-types ,(cond ((eq conditional t)
1466                             :conditional)
1467                            (conditional
1468                             `'(:conditional . ,conditional))
1469                            (t
1470                             `(list ,@(mapcar #'make-operand-type results))))
1471       :more-results-type ,(when more-results
1472                             (make-operand-type more-result)))))
1473 \f
1474 ;;;; setting up VOP-INFO
1475
1476 (eval-when (:compile-toplevel :load-toplevel :execute)
1477   (defparameter *slot-inherit-alist*
1478     '((:generator-function . vop-info-generator-function))))
1479
1480 ;;; This is something to help with inheriting VOP-INFO slots. We
1481 ;;; return a keyword/value pair that can be passed to the constructor.
1482 ;;; SLOT is the keyword name of the slot, Parse is a form that
1483 ;;; evaluates to the VOP-PARSE structure for the VOP inherited. If
1484 ;;; PARSE is NIL, then we do nothing. If the TEST form evaluates to
1485 ;;; true, then we return a form that selects the named slot from the
1486 ;;; VOP-INFO structure corresponding to PARSE. Otherwise, we return
1487 ;;; the FORM so that the slot is recomputed.
1488 (defmacro inherit-vop-info (slot parse test form)
1489   `(if (and ,parse ,test)
1490        (list ,slot `(,',(or (cdr (assoc slot *slot-inherit-alist*))
1491                             (error "unknown slot ~S" slot))
1492                      (template-or-lose ',(vop-parse-name ,parse))))
1493        (list ,slot ,form)))
1494
1495 ;;; Return a form that creates a VOP-INFO structure which describes VOP.
1496 (defun set-up-vop-info (iparse parse)
1497   (declare (type vop-parse parse) (type (or vop-parse null) iparse))
1498   (let ((same-operands
1499          (and iparse
1500               (equal (vop-parse-operands parse)
1501                      (vop-parse-operands iparse))
1502               (equal (vop-parse-info-args iparse)
1503                      (vop-parse-info-args parse))))
1504         (variant (vop-parse-variant parse)))
1505
1506     (let ((nvars (length (vop-parse-variant-vars parse))))
1507       (unless (= (length variant) nvars)
1508         (error "expected ~W variant values: ~S" nvars variant)))
1509
1510     `(make-vop-info
1511       :name ',(vop-parse-name parse)
1512       ,@(make-vop-info-types parse)
1513       :guard ,(when (vop-parse-guard parse)
1514                 `(lambda () ,(vop-parse-guard parse)))
1515       :note ',(vop-parse-note parse)
1516       :info-arg-count ,(length (vop-parse-info-args parse))
1517       :ltn-policy ',(vop-parse-ltn-policy parse)
1518       :save-p ',(vop-parse-save-p parse)
1519       :move-args ',(vop-parse-move-args parse)
1520       :effects (vop-attributes ,@(vop-parse-effects parse))
1521       :affected (vop-attributes ,@(vop-parse-affected parse))
1522       ,@(make-costs-and-restrictions parse)
1523       ,@(make-emit-function-and-friends parse)
1524       ,@(inherit-vop-info :generator-function iparse
1525           (and same-operands
1526                (equal (vop-parse-body parse) (vop-parse-body iparse)))
1527           (unless (eq (vop-parse-body parse) :unspecified)
1528             (make-generator-function parse)))
1529       :variant (list ,@variant))))
1530 \f
1531 ;;; Define the symbol NAME to be a Virtual OPeration in the compiler.
1532 ;;; If specified, INHERITS is the name of a VOP that we default
1533 ;;; unspecified information from. Each SPEC is a list beginning with a
1534 ;;; keyword indicating the interpretation of the other forms in the
1535 ;;; SPEC:
1536 ;;;
1537 ;;; :ARGS {(Name {Key Value}*)}*
1538 ;;; :RESULTS {(Name {Key Value}*)}*
1539 ;;;     The Args and Results are specifications of the operand TNs passed
1540 ;;;     to the VOP. If there is an inherited VOP, any unspecified options
1541 ;;;     are defaulted from the inherited argument (or result) of the same
1542 ;;;     name. The following operand options are defined:
1543 ;;;
1544 ;;;     :SCs (SC*)
1545 ;;;         :SCs specifies good SCs for this operand. Other SCs will
1546 ;;;         be penalized according to move costs. A load TN will be
1547 ;;;         allocated if necessary, guaranteeing that the operand is
1548 ;;;         always one of the specified SCs.
1549 ;;;
1550 ;;;     :LOAD-TN Load-Name
1551 ;;;         Load-Name is bound to the load TN allocated for this
1552 ;;;         operand, or to NIL if no load TN was allocated.
1553 ;;;
1554 ;;;     :LOAD-IF EXPRESSION
1555 ;;;         Controls whether automatic operand loading is done.
1556 ;;;         EXPRESSION is evaluated with the fixed operand TNs bound.
1557 ;;;         If EXPRESSION is true,then loading is done and the variable
1558 ;;;         is bound to the load TN in the generator body. Otherwise,
1559 ;;;         loading is not done, and the variable is bound to the actual
1560 ;;;         operand.
1561 ;;;
1562 ;;;     :MORE T-or-NIL
1563 ;;;         If specified, NAME is bound to the TN-REF for the first
1564 ;;;         argument or result following the fixed arguments or results.
1565 ;;;         A :MORE operand must appear last, and cannot be targeted or
1566 ;;;         restricted.
1567 ;;;
1568 ;;;     :TARGET Operand
1569 ;;;         This operand is targeted to the named operand, indicating a
1570 ;;;         desire to pack in the same location. Not legal for results.
1571 ;;;
1572 ;;;     :FROM Time-Spec
1573 ;;;     :TO Time-Spec
1574 ;;;         Specify the beginning or end of the operand's lifetime.
1575 ;;;         :FROM can only be used with results, and :TO only with
1576 ;;;         arguments. The default for the N'th argument/result is
1577 ;;;         (:ARGUMENT N)/(:RESULT N). These options are necessary
1578 ;;;         primarily when operands are read or written out of order.
1579 ;;;
1580 ;;; :CONDITIONAL [Condition-descriptor+]
1581 ;;;     This is used in place of :RESULTS with conditional branch VOPs.
1582 ;;;     There are no result values: the result is a transfer of control.
1583 ;;;     The target label is passed as the first :INFO arg. The second
1584 ;;;     :INFO arg is true if the sense of the test should be negated.
1585 ;;;     A side effect is to set the PREDICATE attribute for functions
1586 ;;;     in the :TRANSLATE option.
1587 ;;;
1588 ;;;     If some condition descriptors are provided, this is a flag-setting
1589 ;;;     VOP. Descriptors are interpreted in an architecture-dependent
1590 ;;;     manner. See the BRANCH-IF VOP in $ARCH/pred.lisp.
1591 ;;;
1592 ;;; :TEMPORARY ({Key Value}*) Name*
1593 ;;;     Allocate a temporary TN for each Name, binding that variable to
1594 ;;;     the TN within the body of the generators. In addition to :TARGET
1595 ;;;     (which is is the same as for operands), the following options are
1596 ;;;     defined:
1597 ;;;
1598 ;;;     :SC SC-Name
1599 ;;;     :OFFSET SB-Offset
1600 ;;;         Force the temporary to be allocated in the specified SC
1601 ;;;         with the specified offset. Offset is evaluated at
1602 ;;;         macroexpand time. If Offset is omitted, the register
1603 ;;;         allocator chooses a free location in SC. If both SC and
1604 ;;;         Offset are omitted, then the temporary is packed according
1605 ;;;         to its primitive type.
1606 ;;;
1607 ;;;     :FROM Time-Spec
1608 ;;;     :TO Time-Spec
1609 ;;;         Similar to the argument/result option, this specifies the
1610 ;;;         start and end of the temporaries' lives. The defaults are
1611 ;;;         :LOAD and :SAVE, i.e. the duration of the VOP. The other
1612 ;;;         intervening phases are :ARGUMENT, :EVAL and :RESULT.
1613 ;;;         Non-zero sub-phases can be specified by a list, e.g. by
1614 ;;;         default the second argument's life ends at (:ARGUMENT 1).
1615 ;;;
1616 ;;; :GENERATOR Cost Form*
1617 ;;;     Specifies the translation into assembly code. Cost is the
1618 ;;;     estimated cost of the code emitted by this generator. The body
1619 ;;;     is arbitrary Lisp code that emits the assembly language
1620 ;;;     translation of the VOP. An ASSEMBLE form is wrapped around
1621 ;;;     the body, so code may be emitted by using the local INST macro.
1622 ;;;     During the evaluation of the body, the names of the operands
1623 ;;;     and temporaries are bound to the actual TNs.
1624 ;;;
1625 ;;; :EFFECTS Effect*
1626 ;;; :AFFECTED Effect*
1627 ;;;     Specifies the side effects that this VOP has and the side
1628 ;;;     effects that effect its execution. If unspecified, these
1629 ;;;     default to the worst case.
1630 ;;;
1631 ;;; :INFO Name*
1632 ;;;     Define some magic arguments that are passed directly to the code
1633 ;;;     generator. The corresponding trailing arguments to VOP or
1634 ;;;     %PRIMITIVE are stored in the VOP structure. Within the body
1635 ;;;     of the generators, the named variables are bound to these
1636 ;;;     values. Except in the case of :CONDITIONAL VOPs, :INFO arguments
1637 ;;;     cannot be specified for VOPS that are the direct translation
1638 ;;;     for a function (specified by :TRANSLATE).
1639 ;;;
1640 ;;; :IGNORE Name*
1641 ;;;     Causes the named variables to be declared IGNORE in the
1642 ;;;     generator body.
1643 ;;;
1644 ;;; :VARIANT Thing*
1645 ;;; :VARIANT-VARS Name*
1646 ;;;     These options provide a way to parameterize families of VOPs
1647 ;;;     that differ only trivially. :VARIANT makes the specified
1648 ;;;     evaluated Things be the "variant" associated with this VOP.
1649 ;;;     :VARIANT-VARS causes the named variables to be bound to the
1650 ;;;     corresponding Things within the body of the generator.
1651 ;;;
1652 ;;; :VARIANT-COST Cost
1653 ;;;     Specifies the cost of this VOP, overriding the cost of any
1654 ;;;     inherited generator.
1655 ;;;
1656 ;;; :NOTE {String | NIL}
1657 ;;;     A short noun-like phrase describing what this VOP "does", i.e.
1658 ;;;     the implementation strategy. If supplied, efficiency notes will
1659 ;;;     be generated when type uncertainty prevents :TRANSLATE from
1660 ;;;     working. NIL inhibits any efficiency note.
1661 ;;;
1662 ;;; :ARG-TYPES    {* | PType | (:OR PType*) | (:CONSTANT Type)}*
1663 ;;; :RESULT-TYPES {* | PType | (:OR PType*)}*
1664 ;;;     Specify the template type restrictions used for automatic
1665 ;;;     translation. If there is a :MORE operand, the last type is the
1666 ;;;     more type. :CONSTANT specifies that the argument must be a
1667 ;;;     compile-time constant of the specified Lisp type. The constant
1668 ;;;     values of :CONSTANT arguments are passed as additional :INFO
1669 ;;;     arguments rather than as :ARGS.
1670 ;;;
1671 ;;; :TRANSLATE Name*
1672 ;;;     This option causes the VOP template to be entered as an IR2
1673 ;;;     translation for the named functions.
1674 ;;;
1675 ;;; :POLICY {:SMALL | :FAST | :SAFE | :FAST-SAFE}
1676 ;;;     Specifies the policy under which this VOP is the best translation.
1677 ;;;
1678 ;;; :GUARD Form
1679 ;;;     Specifies a Form that is evaluated in the global environment.
1680 ;;;     If form returns NIL, then emission of this VOP is prohibited
1681 ;;;     even when all other restrictions are met.
1682 ;;;
1683 ;;; :VOP-VAR Name
1684 ;;; :NODE-VAR Name
1685 ;;;     In the generator, bind the specified variable to the VOP or
1686 ;;;     the Node that generated this VOP.
1687 ;;;
1688 ;;; :SAVE-P {NIL | T | :COMPUTE-ONLY | :FORCE-TO-STACK}
1689 ;;;     Indicates how a VOP wants live registers saved.
1690 ;;;
1691 ;;; :MOVE-ARGS {NIL | :FULL-CALL | :LOCAL-CALL | :KNOWN-RETURN}
1692 ;;;     Indicates if and how the more args should be moved into a
1693 ;;;     different frame.
1694 (def!macro define-vop ((name &optional inherits) &body specs)
1695   (declare (type symbol name))
1696   ;; Parse the syntax into a VOP-PARSE structure, and then expand into
1697   ;; code that creates the appropriate VOP-INFO structure at load time.
1698   ;; We implement inheritance by copying the VOP-PARSE structure for
1699   ;; the inherited structure.
1700   (let* ((inherited-parse (when inherits
1701                             (vop-parse-or-lose inherits)))
1702          (parse (if inherits
1703                     (copy-vop-parse inherited-parse)
1704                     (make-vop-parse)))
1705          (n-res (gensym)))
1706     (setf (vop-parse-name parse) name)
1707     (setf (vop-parse-inherits parse) inherits)
1708
1709     (parse-define-vop parse specs)
1710     (!grovel-vop-operands parse)
1711
1712     `(progn
1713        (eval-when (:compile-toplevel :load-toplevel :execute)
1714          (setf (gethash ',name *backend-parsed-vops*)
1715                ',parse))
1716
1717        (let ((,n-res ,(set-up-vop-info inherited-parse parse)))
1718          (setf (gethash ',name *backend-template-names*) ,n-res)
1719          (setf (template-type ,n-res)
1720                (specifier-type (template-type-specifier ,n-res)))
1721          ,@(!set-up-fun-translation parse n-res))
1722        ',name)))
1723 \f
1724 ;;;; emission macros
1725
1726 ;;; Return code to make a list of VOP arguments or results, linked by
1727 ;;; TN-REF-ACROSS. The first value is code, the second value is LET*
1728 ;;; forms, and the third value is a variable that evaluates to the
1729 ;;; head of the list, or NIL if there are no operands. Fixed is a list
1730 ;;; of forms that evaluate to TNs for the fixed operands. TN-REFS will
1731 ;;; be made for these operands according using the specified value of
1732 ;;; WRITE-P. More is an expression that evaluates to a list of TN-REFS
1733 ;;; that will be made the tail of the list. If it is constant NIL,
1734 ;;; then we don't bother to set the tail.
1735 (defun make-operand-list (fixed more write-p)
1736   (collect ((forms)
1737             (binds))
1738     (let ((n-head nil)
1739           (n-prev nil))
1740       (dolist (op fixed)
1741         (let ((n-ref (gensym)))
1742           (binds `(,n-ref (reference-tn ,op ,write-p)))
1743           (if n-prev
1744               (forms `(setf (tn-ref-across ,n-prev) ,n-ref))
1745               (setq n-head n-ref))
1746           (setq n-prev n-ref)))
1747
1748       (when more
1749         (let ((n-more (gensym)))
1750           (binds `(,n-more ,more))
1751           (if n-prev
1752               (forms `(setf (tn-ref-across ,n-prev) ,n-more))
1753               (setq n-head n-more))))
1754
1755       (values (forms) (binds) n-head))))
1756
1757 ;;; Emit-Template Node Block Template Args Results [Info]
1758 ;;;
1759 ;;; Call the emit function for TEMPLATE, linking the result in at the
1760 ;;; end of BLOCK.
1761 (defmacro emit-template (node block template args results &optional info)
1762   (with-unique-names (first last)
1763     (once-only ((n-node node)
1764                 (n-block block)
1765                 (n-template template))
1766       `(multiple-value-bind (,first ,last)
1767            (funcall (template-emit-function ,n-template)
1768                     ,n-node ,n-block ,n-template ,args ,results
1769                     ,@(when info `(,info)))
1770          (insert-vop-sequence ,first ,last ,n-block nil)))))
1771
1772 ;;; VOP Name Node Block Arg* Info* Result*
1773 ;;;
1774 ;;; Emit the VOP (or other template) NAME at the end of the IR2-BLOCK
1775 ;;; BLOCK, using NODE for the source context. The interpretation of
1776 ;;; the remaining arguments depends on the number of operands of
1777 ;;; various kinds that are declared in the template definition. VOP
1778 ;;; cannot be used for templates that have more-args or more-results,
1779 ;;; since the number of arguments and results is indeterminate for
1780 ;;; these templates. Use VOP* instead.
1781 ;;;
1782 ;;; ARGS and RESULTS are the TNs that are to be referenced by the
1783 ;;; template as arguments and results. If the template has
1784 ;;; codegen-info arguments, then the appropriate number of INFO forms
1785 ;;; following the arguments are used for codegen info.
1786 (defmacro vop (name node block &rest operands)
1787   (let* ((parse (vop-parse-or-lose name))
1788          (arg-count (length (vop-parse-args parse)))
1789          (result-count (length (vop-parse-results parse)))
1790          (info-count (length (vop-parse-info-args parse)))
1791          (noperands (+ arg-count result-count info-count))
1792          (n-node (gensym))
1793          (n-block (gensym))
1794          (n-template (gensym)))
1795
1796     (when (or (vop-parse-more-args parse) (vop-parse-more-results parse))
1797       (error "cannot use VOP with variable operand count templates"))
1798     (unless (= noperands (length operands))
1799       (error "called with ~W operands, but was expecting ~W"
1800              (length operands) noperands))
1801
1802     (multiple-value-bind (acode abinds n-args)
1803         (make-operand-list (subseq operands 0 arg-count) nil nil)
1804       (multiple-value-bind (rcode rbinds n-results)
1805           (make-operand-list (subseq operands (+ arg-count info-count)) nil t)
1806
1807         (collect ((ibinds)
1808                   (ivars))
1809           (dolist (info (subseq operands arg-count (+ arg-count info-count)))
1810             (let ((temp (gensym)))
1811               (ibinds `(,temp ,info))
1812               (ivars temp)))
1813
1814           `(let* ((,n-node ,node)
1815                   (,n-block ,block)
1816                   (,n-template (template-or-lose ',name))
1817                   ,@abinds
1818                   ,@(ibinds)
1819                   ,@rbinds)
1820              ,@acode
1821              ,@rcode
1822              (emit-template ,n-node ,n-block ,n-template ,n-args
1823                             ,n-results
1824                             ,@(when (ivars)
1825                                 `((list ,@(ivars)))))
1826              (values)))))))
1827
1828 ;;; VOP* Name Node Block (Arg* More-Args) (Result* More-Results) Info*
1829 ;;;
1830 ;;; This is like VOP, but allows for emission of templates with
1831 ;;; arbitrary numbers of arguments, and for emission of templates
1832 ;;; using already-created TN-REF lists.
1833 ;;;
1834 ;;; The ARGS and RESULTS are TNs to be referenced as the first
1835 ;;; arguments and results to the template. More-Args and More-Results
1836 ;;; are heads of TN-REF lists that are added onto the end of the
1837 ;;; TN-REFS for the explicitly supplied operand TNs. The TN-REFS for
1838 ;;; the more operands must have the TN and WRITE-P slots correctly
1839 ;;; initialized.
1840 ;;;
1841 ;;; As with VOP, the INFO forms are evaluated and passed as codegen
1842 ;;; info arguments.
1843 (defmacro vop* (name node block args results &rest info)
1844   (declare (type cons args results))
1845   (let* ((parse (vop-parse-or-lose name))
1846          (arg-count (length (vop-parse-args parse)))
1847          (result-count (length (vop-parse-results parse)))
1848          (info-count (length (vop-parse-info-args parse)))
1849          (fixed-args (butlast args))
1850          (fixed-results (butlast results))
1851          (n-node (gensym))
1852          (n-block (gensym))
1853          (n-template (gensym)))
1854
1855     (unless (or (vop-parse-more-args parse)
1856                 (<= (length fixed-args) arg-count))
1857       (error "too many fixed arguments"))
1858     (unless (or (vop-parse-more-results parse)
1859                 (<= (length fixed-results) result-count))
1860       (error "too many fixed results"))
1861     (unless (= (length info) info-count)
1862       (error "expected ~W info args" info-count))
1863
1864     (multiple-value-bind (acode abinds n-args)
1865         (make-operand-list fixed-args (car (last args)) nil)
1866       (multiple-value-bind (rcode rbinds n-results)
1867           (make-operand-list fixed-results (car (last results)) t)
1868
1869         `(let* ((,n-node ,node)
1870                 (,n-block ,block)
1871                 (,n-template (template-or-lose ',name))
1872                 ,@abinds
1873                 ,@rbinds)
1874            ,@acode
1875            ,@rcode
1876            (emit-template ,n-node ,n-block ,n-template ,n-args ,n-results
1877                           ,@(when info
1878                               `((list ,@info))))
1879            (values))))))
1880 \f
1881 ;;;; miscellaneous macros
1882
1883 ;;; SC-Case TN {({(SC-Name*) | SC-Name | T} Form*)}*
1884 ;;;
1885 ;;; Case off of TN's SC. The first clause containing TN's SC is
1886 ;;; evaluated, returning the values of the last form. A clause
1887 ;;; beginning with T specifies a default. If it appears, it must be
1888 ;;; last. If no default is specified, and no clause matches, then an
1889 ;;; error is signalled.
1890 (def!macro sc-case (tn &body forms)
1891   (let ((n-sc (gensym))
1892         (n-tn (gensym)))
1893     (collect ((clauses))
1894       (do ((cases forms (rest cases)))
1895           ((null cases)
1896            (clauses `(t (error "unknown SC to SC-CASE for ~S:~%  ~S" ,n-tn
1897                                (sc-name (tn-sc ,n-tn))))))
1898         (let ((case (first cases)))
1899           (when (atom case)
1900             (error "illegal SC-CASE clause: ~S" case))
1901           (let ((head (first case)))
1902             (when (eq head t)
1903               (when (rest cases)
1904                 (error "T case is not last in SC-CASE."))
1905               (clauses `(t nil ,@(rest case)))
1906               (return))
1907             (clauses `((or ,@(mapcar (lambda (x)
1908                                        `(eql ,(meta-sc-number-or-lose x)
1909                                              ,n-sc))
1910                                      (if (atom head) (list head) head)))
1911                        nil ,@(rest case))))))
1912
1913       `(let* ((,n-tn ,tn)
1914               (,n-sc (sc-number (tn-sc ,n-tn))))
1915          (cond ,@(clauses))))))
1916
1917 ;;; Return true if TNs SC is any of the named SCs, false otherwise.
1918 (defmacro sc-is (tn &rest scs)
1919   (once-only ((n-sc `(sc-number (tn-sc ,tn))))
1920     `(or ,@(mapcar (lambda (x)
1921                      `(eql ,n-sc ,(meta-sc-number-or-lose x)))
1922                    scs))))
1923
1924 ;;; Iterate over the IR2 blocks in component, in emission order.
1925 (defmacro do-ir2-blocks ((block-var component &optional result)
1926                          &body forms)
1927   `(do ((,block-var (block-info (component-head ,component))
1928                     (ir2-block-next ,block-var)))
1929        ((null ,block-var) ,result)
1930      ,@forms))
1931
1932 ;;; Iterate over all the TNs live at some point, with the live set
1933 ;;; represented by a local conflicts bit-vector and the IR2-BLOCK
1934 ;;; containing the location.
1935 (defmacro do-live-tns ((tn-var live block &optional result) &body body)
1936   (with-unique-names (conf bod i ltns)
1937     (once-only ((n-live live)
1938                 (n-block block))
1939       `(block nil
1940          (flet ((,bod (,tn-var) ,@body))
1941            ;; Do component-live TNs.
1942            (dolist (,tn-var (ir2-component-component-tns
1943                              (component-info
1944                               (block-component
1945                                (ir2-block-block ,n-block)))))
1946              (,bod ,tn-var))
1947
1948            (let ((,ltns (ir2-block-local-tns ,n-block)))
1949              ;; Do TNs always-live in this block and live :MORE TNs.
1950              (do ((,conf (ir2-block-global-tns ,n-block)
1951                          (global-conflicts-next-blockwise ,conf)))
1952                  ((null ,conf))
1953                (when (or (eq (global-conflicts-kind ,conf) :live)
1954                          (let ((,i (global-conflicts-number ,conf)))
1955                            (and (eq (svref ,ltns ,i) :more)
1956                                 (not (zerop (sbit ,n-live ,i))))))
1957                  (,bod (global-conflicts-tn ,conf))))
1958              ;; Do TNs locally live in the designated live set.
1959              (dotimes (,i (ir2-block-local-tn-count ,n-block) ,result)
1960                (unless (zerop (sbit ,n-live ,i))
1961                  (let ((,tn-var (svref ,ltns ,i)))
1962                    (when (and ,tn-var (not (eq ,tn-var :more)))
1963                      (,bod ,tn-var)))))))))))
1964
1965 ;;; Iterate over all the IR2 blocks in PHYSENV, in emit order.
1966 (defmacro do-physenv-ir2-blocks ((block-var physenv &optional result)
1967                                  &body body)
1968   (once-only ((n-physenv physenv))
1969     (once-only ((n-first `(lambda-block (physenv-lambda ,n-physenv))))
1970       (once-only ((n-tail `(block-info
1971                             (component-tail
1972                              (block-component ,n-first)))))
1973         `(do ((,block-var (block-info ,n-first)
1974                           (ir2-block-next ,block-var)))
1975              ((or (eq ,block-var ,n-tail)
1976                   (not (eq (ir2-block-physenv ,block-var) ,n-physenv)))
1977               ,result)
1978            ,@body)))))