/[cmucl]/src/compiler/meta-vmdef.lisp
ViewVC logotype

Contents of /src/compiler/meta-vmdef.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5