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

  ViewVC Help
Powered by ViewVC 1.1.5