/[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.1 - (show annotations)
Tue Aug 25 17:45:43 1992 UTC (21 years, 7 months ago) by wlott
Branch: MAIN
Initial revision
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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/meta-vmdef.lisp,v 1.1 1992/08/25 17:45:43 wlott Exp $")
11 ;;;
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 (:make-load-form-fun :just-dump-it-normally))
426 ;;
427 ;; The name of this VOP.
428 (name nil :type symbol)
429 ;;
430 ;; If true, then the name of the VOP we inherit from.
431 (inherits nil :type (or symbol null))
432 ;;
433 ;; Lists of Operand-Parse structures describing the arguments, results and
434 ;; temporaries of the VOP.
435 (args nil :type list)
436 (results nil :type list)
437 (temps nil :type list)
438 ;;
439 ;; Operand-Parse structures containing information about more args and
440 ;; results. If null, then there there are no more operands of that kind.
441 (more-args nil :type (or operand-parse null))
442 (more-results nil :type (or operand-parse null))
443 ;;
444 ;; A list of all the above together.
445 (operands nil :type list)
446 ;;
447 ;; Names of variables that should be declared ignore.
448 (ignores () :type list)
449 ;;
450 ;; True if this is a :Conditional VOP.
451 (conditional-p nil)
452 ;;
453 ;; Argument and result primitive types. These are pulled out of the
454 ;; operands, since we often want to change them without respecifying the
455 ;; operands.
456 (arg-types :unspecified :type (or (member :unspecified) list))
457 (result-types :unspecified :type (or (member :unspecified) list))
458 ;;
459 ;; The guard expression specified, or NIL if none.
460 (guard nil)
461 ;;
462 ;; The cost of and body code for the generator.
463 (cost 0 :type unsigned-byte)
464 (body :unspecified :type (or (member :unspecified) list))
465 ;;
466 ;; Info for VOP variants. The list of forms to be evaluated to get the
467 ;; variant args for this VOP, and the list of variables to be bound to the
468 ;; variant args.
469 (variant () :type list)
470 (variant-vars () :type list)
471 ;;
472 ;; Variables bound to the VOP and Vop-Node when in the generator body.
473 (vop-var (gensym) :type symbol)
474 (node-var nil :type (or symbol null))
475 ;;
476 ;; A list of the names of the codegen-info arguments to this VOP.
477 (info-args () :type list)
478 ;;
479 ;; An efficiency note associated with this VOP.
480 (note nil :type (or string null))
481 ;;
482 ;; A list of the names of the Effects and Affected attributes for this VOP.
483 (effects '(any) :type list)
484 (affected '(any) :type list)
485 ;;
486 ;; A list of the names of functions this VOP is a translation of and the
487 ;; policy that allows this translation to be done. :Fast is a safe default,
488 ;; since it isn't a safe policy.
489 (translate () :type list)
490 (policy :fast :type policies)
491 ;;
492 ;; Stuff used by life analysis.
493 (save-p nil :type (member t nil :compute-only :force-to-stack))
494 ;;
495 ;; Info about how to emit move-argument VOPs for the more operand in
496 ;; call/return VOPs.
497 (move-args nil :type (member nil :local-call :full-call :known-return)))
498
499
500 (defprinter vop-parse
501 name
502 (inherits :test inherits)
503 args
504 results
505 temps
506 (more-args :test more-args)
507 (more-results :test more-results)
508 (conditional-p :test conditional-p)
509 ignores
510 arg-types
511 result-types
512 cost
513 body
514 (variant :test variant)
515 (variant-vars :test variant-vars)
516 (info-args :test info-args)
517 (note :test note)
518 effects
519 affected
520 translate
521 policy
522 (save-p :test save-p)
523 (move-args :test move-args))
524
525 ;;; The Operand-Parse structure contains stuff we need to know about and
526 ;;; operand or temporary at meta-compile time. Besides the obvious stuff, we
527 ;;; also store the names of per-operand temporaries here.
528 ;;;
529 (defstruct (operand-parse
530 (:print-function %print-operand-parse)
531 (:make-load-form-fun :just-dump-it-normally))
532 ;;
533 ;; Name of the operand (which we bind to the TN).
534 (name nil :type symbol)
535 ;;
536 ;; The way this operand is used:
537 (kind (required-argument)
538 :type (member :argument :result :temporary
539 :more-argument :more-result))
540 ;;
541 ;; If true, the name of an operand that this operand is targeted to. This is
542 ;; only meaningful in :Argument and :Temporary operands.
543 (target nil :type (or symbol null))
544 ;;
545 ;; Temporary that holds the TN-Ref for this operand. Temp-Temp holds the
546 ;; write reference that begins a temporary's lifetime.
547 (temp (gensym) :type symbol)
548 (temp-temp nil :type (or symbol null))
549 ;;
550 ;; The time that this operand is first live and the time at which it becomes
551 ;; dead again. These are time-specs, as returned by parse-time-spec.
552 born
553 dies
554 ;;
555 ;; A list of the names of the SCs that this operand is allowed into. If
556 ;; false, there is no restriction.
557 (scs nil :type list)
558 ;;
559 ;; Variable that is bound to the load TN allocated for this operand, or to
560 ;; NIL if no load-TN was allocated.
561 (load-tn (gensym) :type symbol)
562 ;;
563 ;; An expression that tests whether to do automatic operand loading.
564 (load t)
565 ;;
566 ;; In a wired or restricted temporary this is the SC the TN is to be packed
567 ;; in. Null otherwise.
568 (sc nil :type (or symbol null))
569 ;;
570 ;; If non-null, we are a temp wired to this offset in SC.
571 (offset nil :type (or unsigned-byte null)))
572
573
574 (defprinter operand-parse
575 name
576 kind
577 (target :test target)
578 born
579 dies
580 (scs :test scs)
581 (load :test load)
582 (sc :test sc)
583 (offset :test offset))
584
585
586 ;;;; Random utilities:
587
588 ;;; Find-Operand -- Internal
589 ;;;
590 ;;; Find the operand or temporary with the specifed Name in the VOP Parse.
591 ;;; If there is no such operand, signal an error. Also error if the operand
592 ;;; kind isn't one of the specified Kinds. If Error-P is NIL, just return NIL
593 ;;; if there is no such operand.
594 ;;;
595 (defun find-operand (name parse &optional
596 (kinds '(:argument :result :temporary))
597 (error-p t))
598 (declare (symbol name) (type vop-parse parse) (list kinds))
599 (let ((found (find name (vop-parse-operands parse)
600 :key #'operand-parse-name)))
601 (if found
602 (unless (member (operand-parse-kind found) kinds)
603 (error "Operand ~S isn't one of these kinds: ~S." name kinds))
604 (when error-p
605 (error "~S is not an operand to ~S." name (vop-parse-name parse))))
606 found))
607
608
609 ;;; VOP-Parse-Or-Lose -- Internal
610 ;;;
611 ;;; Get the VOP-Parse structure for Name or die trying. For all
612 ;;; meta-compile time uses, the VOP-Parse should be used instead of the
613 ;;; VOP-Info
614 ;;;
615 (defun vop-parse-or-lose (name &optional (backend *target-backend*))
616 (the vop-parse
617 (or (gethash name (backend-parsed-vops backend))
618 (error "~S is not the name of a defined VOP." name))))
619
620
621 ;;; Access-Operands -- Internal
622 ;;;
623 ;;; Return a list of let-forms to parse a tn-ref list into a the temps
624 ;;; specified by the operand-parse structures. More-Operand is the
625 ;;; Operand-Parse describing any more operand, or NIL if none. Refs is an
626 ;;; expression that evaluates into the first tn-ref.
627 ;;;
628 (defun access-operands (operands more-operand refs)
629 (declare (list operands))
630 (collect ((res))
631 (let ((prev refs))
632 (dolist (op operands)
633 (let ((n-ref (operand-parse-temp op)))
634 (res `(,n-ref ,prev))
635 (setq prev `(tn-ref-across ,n-ref))))
636
637 (when more-operand
638 (res `(,(operand-parse-name more-operand) ,prev))))
639 (res)))
640
641
642 ;;; Ignore-Unreferenced-Temps -- Internal
643 ;;;
644 ;;; Used with Access-Operands to prevent warnings for TN-Ref temps not used
645 ;;; by some particular function. It returns the name of the last operand, or
646 ;;; NIL if Operands is NIL.
647 ;;;
648 (defun ignore-unreferenced-temps (operands)
649 (when operands
650 (operand-parse-temp (car (last operands)))))
651
652
653 ;;; VOP-Spec-Arg -- Internal
654 ;;;
655 ;;; Grab an arg out of a VOP spec, checking the type and syntax and stuff.
656 ;;;
657 (defun vop-spec-arg (spec type &optional (n 1) (last t))
658 (let ((len (length spec)))
659 (when (<= len n)
660 (error "~:R argument missing: ~S." n spec))
661 (when (and last (> len (1+ n)))
662 (error "Extra junk at end of ~S." spec))
663 (let ((thing (elt spec n)))
664 (unless (typep thing type)
665 (error "~:R argument is not a ~S: ~S." n type spec))
666 thing)))
667
668
669 ;;;; Time specs:
670
671 ;;; Parse-Time-Spec -- Internal
672 ;;;
673 ;;; Return a time spec describing a time during the evaluation of a VOP,
674 ;;; used to delimit operand and temporary lifetimes. The representation is a
675 ;;; cons whose CAR is the number of the evaluation phase and the CDR is the
676 ;;; sub-phase. The sub-phase is 0 in the :Load and :Save phases.
677 ;;;
678 (defun parse-time-spec (spec)
679 (let ((dspec (if (atom spec) (list spec 0) spec)))
680 (unless (and (= (length dspec) 2)
681 (typep (second dspec) 'unsigned-byte))
682 (error "Malformed time specifier: ~S." spec))
683
684 (cons (case (first dspec)
685 (:load 0)
686 (:argument 1)
687 (:eval 2)
688 (:result 3)
689 (:save 4)
690 (t
691 (error "Unknown phase in time specifier: ~S." spec)))
692 (second dspec))))
693
694
695 ;;; Time-Spec-Order -- Internal
696 ;;;
697 ;;; Return true if the time spec X is the same or later time than Y.
698 ;;;
699 (defun time-spec-order (x y)
700 (or (> (car x) (car y))
701 (and (= (car x) (car y))
702 (>= (cdr x) (cdr y)))))
703
704
705 ;;;; Emit function generation:
706
707 (defun compute-temporaries-description (parse)
708 (let ((temps (vop-parse-temps parse)))
709 (when temps
710 (let ((results (make-array (length temps)
711 :element-type '(unsigned-byte 16)))
712 (index 0))
713 (dolist (temp temps)
714 (declare (type operand-parse temp))
715 (let ((sc (operand-parse-sc temp))
716 (offset (operand-parse-offset temp)))
717 (assert sc)
718 (setf (aref results index)
719 (if offset
720 (+ (ash offset (1+ sc-bits))
721 (ash (meta-sc-number-or-lose sc) 1)
722 1)
723 (ash (meta-sc-number-or-lose sc) 1))))
724 (incf index))
725 results))))
726
727 (defun compute-ref-ordering (parse)
728 (let* ((num-args (+ (length (vop-parse-args parse))
729 (if (vop-parse-more-args parse) 1 0)))
730 (num-results (+ (length (vop-parse-results parse))
731 (if (vop-parse-more-results parse) 1 0)))
732 (index 0))
733 (collect ((refs) (targets))
734 (dolist (op (vop-parse-operands parse))
735 (when (operand-parse-target op)
736 (unless (member (operand-parse-kind op) '(:argument :temporary))
737 (error "Cannot target a ~S operand: ~S." (operand-parse-kind op)
738 (operand-parse-name op)))
739 (let ((target (find-operand (operand-parse-target op) parse
740 '(:temporary :result))))
741 (targets (+ (* index max-vop-tn-refs)
742 (ecase (operand-parse-kind target)
743 (:result
744 (+ (position target (vop-parse-results parse))
745 num-args))
746 (:temporary
747 (+ (* (position target (vop-parse-temps parse)) 2)
748 num-args num-results)))))))
749 (let ((born (operand-parse-born op))
750 (dies (operand-parse-dies op)))
751 (ecase (operand-parse-kind op)
752 (:argument
753 (refs (cons (cons dies nil) index)))
754 (:more-argument
755 (refs (cons (cons dies nil) index)))
756 (:result
757 (refs (cons (cons born t) index)))
758 (:more-result
759 (refs (cons (cons born t) index)))
760 (:temporary
761 (refs (cons (cons dies nil) index))
762 (incf index)
763 (refs (cons (cons born t) index))))
764 (incf index)))
765 (let* ((sorted (sort (refs)
766 #'(lambda (x y)
767 (let ((x-time (car x))
768 (y-time (car y)))
769 (if (time-spec-order x-time y-time)
770 (if (time-spec-order y-time x-time)
771 (and (not (cdr x)) (cdr y))
772 nil)
773 t)))
774 :key #'car))
775 (ordering (make-array (length sorted)
776 :element-type '(mod #.max-vop-tn-refs))))
777 (let ((index 0))
778 (dolist (ref sorted)
779 (setf (aref ordering index) (cdr ref))
780 (incf index)))
781 `(:num-args ,num-args
782 :num-results ,num-results
783 :ref-ordering ,ordering
784 ,@(when (targets)
785 `(:targets
786 ,(make-array (length (targets))
787 :element-type '(mod #.(* max-vop-tn-refs 2))
788 :initial-contents (targets)))))))))
789
790 (defun make-emit-function-and-friends (parse)
791 `(:emit-function #'emit-generic-vop
792 :temps ',(compute-temporaries-description parse)
793 ,@(compute-ref-ordering parse)))
794
795
796 ;;;; Generator functions:
797
798 ;;; FIND-MOVE-FUNCTIONS -- Internal
799 ;;;
800 ;;; Return an alist that translates from lists of SCs we can load OP from to
801 ;;; the move function used for loading those SCs. We quietly ignore
802 ;;; restrictions to :non-packed (constant) and :unbounded SCs, since we don't
803 ;;; load into those SCs.
804 ;;;
805 (defun find-move-functions (op load-p)
806 (collect ((funs))
807 (dolist (sc-name (operand-parse-scs op))
808 (let* ((sc (meta-sc-or-lose sc-name))
809 (scn (sc-number sc))
810 (load-scs (append (when load-p
811 (sc-constant-scs sc))
812 (sc-alternate-scs sc))))
813 (cond
814 (load-scs
815 (dolist (alt load-scs)
816 (unless (member (sc-name alt) (operand-parse-scs op) :test #'eq)
817 (let* ((altn (sc-number alt))
818 (name (if load-p
819 (svref (sc-move-functions sc) altn)
820 (svref (sc-move-functions alt) scn)))
821 (found (or (assoc alt (funs) :test #'member)
822 (rassoc name (funs)))))
823 (unless name
824 (error "No move function defined to ~:[save~;load~] SC ~S~
825 ~:[to~;from~] from SC ~S."
826 load-p sc-name load-p (sc-name alt)))
827
828 (cond (found
829 (unless (eq (cdr found) name)
830 (error "Can't tell whether to ~:[save~;load~] with ~S~@
831 or ~S when operand is in SC ~S."
832 load-p name (cdr found) (sc-name alt)))
833 (pushnew alt (car found)))
834 (t
835 (funs (cons (list alt) name))))))))
836 ((member (sb-kind (sc-sb sc)) '(:non-packed :unbounded)))
837 (t
838 (error "SC ~S has no alternate~:[~; or constant~] SCs, yet it is~@
839 mentioned in the restriction for operand ~S."
840 sc-name load-p (operand-parse-name op))))))
841 (funs)))
842
843 ;;; DECIDE-TO-LOAD -- Internal
844 ;;;
845 ;;; Return the TN that we should bind to the operand's var in the generator
846 ;;; body. In general, this involves evaluating the :LOAD-IF test expression.
847 ;;;
848 (defun decide-to-load (parse op)
849 (let ((load (operand-parse-load op))
850 (load-tn (operand-parse-load-tn op))
851 (temp (operand-parse-temp op)))
852 (if (eq load t)
853 `(or ,load-tn (tn-ref-tn ,temp))
854 (collect ((binds)
855 (ignores))
856 (dolist (x (vop-parse-operands parse))
857 (when (member (operand-parse-kind x) '(:argument :result))
858 (let ((name (operand-parse-name x)))
859 (binds `(,name (tn-ref-tn ,(operand-parse-temp x))))
860 (ignores name))))
861 `(if (and ,load-tn
862 (let ,(binds)
863 #+new-compiler
864 (declare (ignorable ,@(ignores)))
865 #-new-compiler
866 (progn ,@(ignores))
867 ,load))
868 ,load-tn
869 (tn-ref-tn ,temp))))))
870
871
872 ;;; Make-Generator-Function -- Internal
873 ;;;
874 ;;; Make a lambda that parses the VOP TN-Refs, does automatic operand
875 ;;; loading, and runs the appropriate code generator.
876 ;;;
877 (defun make-generator-function (parse)
878 (declare (type vop-parse parse))
879 (let ((n-vop (vop-parse-vop-var parse))
880 (operands (vop-parse-operands parse))
881 (n-info (gensym)) (n-variant (gensym)))
882 (collect ((binds)
883 (loads)
884 (saves))
885 (dolist (op operands)
886 (ecase (operand-parse-kind op)
887 ((:argument :result)
888 (let ((temp (operand-parse-temp op))
889 (name (operand-parse-name op)))
890 (cond ((and (operand-parse-load op) (operand-parse-scs op))
891 (binds `(,(operand-parse-load-tn op)
892 (tn-ref-load-tn ,temp)))
893 (binds `(,name ,(decide-to-load parse op)))
894 (if (eq (operand-parse-kind op) :argument)
895 (loads (call-move-function parse op t))
896 (saves (call-move-function parse op nil))))
897 (t
898 (binds `(,name (tn-ref-tn ,temp)))))))
899 (:temporary
900 (binds `(,(operand-parse-name op)
901 (tn-ref-tn ,(operand-parse-temp op)))))
902 ((:more-argument :more-result))))
903
904 `#'(lambda (,n-vop)
905 (let* (,@(access-operands (vop-parse-args parse)
906 (vop-parse-more-args parse)
907 `(vop-args ,n-vop))
908 ,@(access-operands (vop-parse-results parse)
909 (vop-parse-more-results parse)
910 `(vop-results ,n-vop))
911 ,@(access-operands (vop-parse-temps parse) nil
912 `(vop-temps ,n-vop))
913 ,@(when (vop-parse-info-args parse)
914 `((,n-info (vop-codegen-info ,n-vop))
915 ,@(mapcar #'(lambda (x) `(,x (pop ,n-info)))
916 (vop-parse-info-args parse))))
917 ,@(when (vop-parse-variant-vars parse)
918 `((,n-variant (vop-info-variant (vop-info ,n-vop)))
919 ,@(mapcar #'(lambda (x) `(,x (pop ,n-variant)))
920 (vop-parse-variant-vars parse))))
921 ,@(when (vop-parse-node-var parse)
922 `((,(vop-parse-node-var parse) (vop-node ,n-vop))))
923 ,@(binds))
924 (declare (ignore ,@(vop-parse-ignores parse)))
925 ,@(loads)
926 (new-assem:assemble (*code-segment* ,n-vop)
927 ,@(vop-parse-body parse))
928 ,@(saves))))))
929
930
931 ;;; Parse-Operands -- Internal
932 ;;;
933 ;;; Given a list of operand specifications as given to Define-VOP, return a
934 ;;; list of Operand-Parse structures describing the fixed operands, and a
935 ;;; single Operand-Parse describing any more operand. If we are inheriting a
936 ;;; VOP, we default attributes to the inherited operand of the same name.
937 ;;;
938 (defun parse-operands (parse specs kind)
939 (declare (list specs)
940 (type (member :argument :result) kind))
941 (let ((num -1)
942 (more nil))
943 (collect ((operands))
944 (dolist (spec specs)
945 (unless (and (consp spec) (symbolp (first spec)) (oddp (length spec)))
946 (error "Malformed operand specifier: ~S." spec))
947 (when more
948 (error "More operand isn't last: ~S." specs))
949 (let* ((name (first spec))
950 (old (if (vop-parse-inherits parse)
951 (find-operand name
952 (vop-parse-or-lose
953 (vop-parse-inherits parse))
954 (list kind)
955 nil)
956 nil))
957 (res (if old
958 (make-operand-parse
959 :name name
960 :kind kind
961 :target (operand-parse-target old)
962 :born (operand-parse-born old)
963 :dies (operand-parse-dies old)
964 :scs (operand-parse-scs old)
965 :load-tn (operand-parse-load-tn old)
966 :load (operand-parse-load old))
967 (ecase kind
968 (:argument
969 (make-operand-parse
970 :name (first spec) :kind :argument
971 :born (parse-time-spec :load)
972 :dies (parse-time-spec `(:argument ,(incf num)))))
973 (:result
974 (make-operand-parse
975 :name (first spec) :kind :result
976 :born (parse-time-spec `(:result ,(incf num)))
977 :dies (parse-time-spec :save)))))))
978 (do ((key (rest spec) (cddr key)))
979 ((null key))
980 (let ((value (second key)))
981 (case (first key)
982 (:scs
983 (check-type value list)
984 (setf (operand-parse-scs res) (remove-duplicates value)))
985 (:load-tn
986 (check-type value symbol)
987 (setf (operand-parse-load-tn res) value))
988 (:load-if
989 (setf (operand-parse-load res) value))
990 (:more
991 (check-type value boolean)
992 (setf (operand-parse-kind res)
993 (if (eq kind :argument) :more-argument :more-result))
994 (setf (operand-parse-load res) nil)
995 (setq more res))
996 (:target
997 (check-type value symbol)
998 (setf (operand-parse-target res) value))
999 (:from
1000 (unless (eq kind :result)
1001 (error "Can only specify :FROM in a result: ~S" spec))
1002 (setf (operand-parse-born res) (parse-time-spec value)))
1003 (:to
1004 (unless (eq kind :argument)
1005 (error "Can only specify :TO in an argument: ~S" spec))
1006 (setf (operand-parse-dies res) (parse-time-spec value)))
1007 (t
1008 (error "Unknown keyword in operand specifier: ~S." spec)))))
1009
1010 (cond ((not more)
1011 (operands res))
1012 ((operand-parse-target more)
1013 (error "Cannot specify :TARGET in a :MORE operand."))
1014 ((operand-parse-load more)
1015 (error "Cannot specify :LOAD-IF in a :MORE operand.")))))
1016 (values (the list (operands)) more))))
1017
1018
1019 ;;; Parse-Temporary -- Internal
1020 ;;;
1021 ;;; Parse a temporary specification, entering the Operand-Parse structures
1022 ;;; in the Parse structure.
1023 ;;;
1024 (defun parse-temporary (spec parse)
1025 (declare (list spec)
1026 (type vop-parse parse))
1027 (let ((len (length spec)))
1028 (unless (>= len 2)
1029 (error "Malformed temporary spec: ~S." spec))
1030 (unless (listp (second spec))
1031 (error "Malformed options list: ~S." (second spec)))
1032 (unless (evenp (length (second spec)))
1033 (error "Odd number of arguments in keyword options: ~S." spec))
1034 (unless (consp (cddr spec))
1035 (warn "Temporary spec allocates no temps:~% ~S" spec))
1036 (dolist (name (cddr spec))
1037 (unless (symbolp name)
1038 (error "Bad temporary name: ~S." name))
1039 (let ((res (make-operand-parse :name name :kind :temporary
1040 :temp-temp (gensym)
1041 :born (parse-time-spec :load)
1042 :dies (parse-time-spec :save))))
1043 (do ((opt (second spec) (cddr opt)))
1044 ((null opt))
1045 (case (first opt)
1046 (:target
1047 (setf (operand-parse-target res)
1048 (vop-spec-arg opt 'symbol 1 nil)))
1049 (:sc
1050 (setf (operand-parse-sc res)
1051 (vop-spec-arg opt 'symbol 1 nil)))
1052 (:offset
1053 (let ((offset (eval (second opt))))
1054 (check-type offset unsigned-byte)
1055 (setf (operand-parse-offset res) offset)))
1056 (:from
1057 (setf (operand-parse-born res) (parse-time-spec (second opt))))
1058 (:to
1059 (setf (operand-parse-dies res) (parse-time-spec (second opt))))
1060 ;;
1061 ;; Backward compatibility...
1062 (:scs
1063 (let ((scs (vop-spec-arg opt 'list 1 nil)))
1064 (unless (= (length scs) 1)
1065 (error "Must specify exactly one SC for a temporary."))
1066 (setf (operand-parse-sc res) (first scs))))
1067 (:type)
1068 (t
1069 (error "Unknown temporary option: ~S." opt))))
1070
1071 (unless (and (time-spec-order (operand-parse-dies res)
1072 (operand-parse-born res))
1073 (not (time-spec-order (operand-parse-born res)
1074 (operand-parse-dies res))))
1075 (error "Temporary lifetime doesn't begin before it ends: ~S." spec))
1076
1077 (unless (operand-parse-sc res)
1078 (error "Must specifiy :SC for all temporaries: ~S" spec))
1079
1080 (setf (vop-parse-temps parse)
1081 (cons res
1082 (remove name (vop-parse-temps parse)
1083 :key #'operand-parse-name))))))
1084 (undefined-value))
1085
1086
1087 ;;; Parse-Define-VOP -- Internal
1088 ;;;
1089 ;;; Top-level parse function. Clobber Parse to represent the specified
1090 ;;; options.
1091 ;;;
1092 (defun parse-define-vop (parse specs)
1093 (declare (type vop-parse parse) (list specs))
1094 (dolist (spec specs)
1095 (unless (consp spec)
1096 (error "Malformed option specification: ~S." spec))
1097 (case (first spec)
1098 (:args
1099 (multiple-value-bind
1100 (fixed more)
1101 (parse-operands parse (rest spec) :argument)
1102 (setf (vop-parse-args parse) fixed)
1103 (setf (vop-parse-more-args parse) more)))
1104 (:results
1105 (multiple-value-bind
1106 (fixed more)
1107 (parse-operands parse (rest spec) :result)
1108 (setf (vop-parse-results parse) fixed)
1109 (setf (vop-parse-more-results parse) more))
1110 (setf (vop-parse-conditional-p parse) nil))
1111 (:conditional
1112 (setf (vop-parse-result-types parse) ())
1113 (setf (vop-parse-results parse) ())
1114 (setf (vop-parse-more-results parse) nil)
1115 (setf (vop-parse-conditional-p parse) t))
1116 (:temporary
1117 (parse-temporary spec parse))
1118 (:generator
1119 (setf (vop-parse-cost parse)
1120 (vop-spec-arg spec 'unsigned-byte 1 nil))
1121 (setf (vop-parse-body parse) (cddr spec)))
1122 (:effects
1123 (setf (vop-parse-effects parse) (rest spec)))
1124 (:affected
1125 (setf (vop-parse-affected parse) (rest spec)))
1126 (:info
1127 (setf (vop-parse-info-args parse) (rest spec)))
1128 (:ignore
1129 (setf (vop-parse-ignores parse) (rest spec)))
1130 (:variant
1131 (setf (vop-parse-variant parse) (rest spec)))
1132 (:variant-vars
1133 (let ((vars (rest spec)))
1134 (setf (vop-parse-variant-vars parse) vars)
1135 (setf (vop-parse-variant parse)
1136 (make-list (length vars) :initial-element nil))))
1137 (:variant-cost
1138 (setf (vop-parse-cost parse) (vop-spec-arg spec 'unsigned-byte)))
1139 (:vop-var
1140 (setf (vop-parse-vop-var parse) (vop-spec-arg spec 'symbol)))
1141 (:move-args
1142 (setf (vop-parse-move-args parse)
1143 (vop-spec-arg spec '(member nil :local-call :full-call
1144 :known-return))))
1145 (:node-var
1146 (setf (vop-parse-node-var parse) (vop-spec-arg spec 'symbol)))
1147 (:note
1148 (setf (vop-parse-note parse) (vop-spec-arg spec '(or string null))))
1149 (:arg-types
1150 (setf (vop-parse-arg-types parse)
1151 (parse-operand-types (rest spec) t)))
1152 (:result-types
1153 (setf (vop-parse-result-types parse)
1154 (parse-operand-types (rest spec) nil)))
1155 (:translate
1156 (setf (vop-parse-translate parse) (rest spec)))
1157 (:guard
1158 (setf (vop-parse-guard parse) (vop-spec-arg spec t)))
1159 (:policy
1160 (setf (vop-parse-policy parse) (vop-spec-arg spec 'policies)))
1161 (:save-p
1162 (setf (vop-parse-save-p parse)
1163 (vop-spec-arg spec
1164 '(member t nil :compute-only :force-to-stack))))
1165 (t
1166 (error "Unknown option specifier: ~S." (first spec)))))
1167 (undefined-value))
1168
1169
1170 ;;;; Make costs and restrictions:
1171
1172 ;;; Compute-Loading-Costs -- Internal
1173 ;;;
1174 ;;; Given an operand, returns two values:
1175 ;;; 1] A SC-vector of the cost for the operand being in that SC, including both
1176 ;;; the costs for move functions and coercion VOPs.
1177 ;;; 2] A SC-vector holding the SC that we load into, for any SC that we can
1178 ;;; directly load from.
1179 ;;;
1180 ;;; In both vectors, unused entries are NIL. Load-P specifies the direction:
1181 ;;; if true, we are loading, if false we are saving.
1182 ;;;
1183 (defun compute-loading-costs (op load-p)
1184 (declare (type operand-parse op))
1185 (let ((scs (operand-parse-scs op))
1186 (costs (make-array sc-number-limit :initial-element nil))
1187 (load-scs (make-array sc-number-limit :initial-element nil)))
1188 (dolist (sc-name scs)
1189 (let* ((load-sc (meta-sc-or-lose sc-name))
1190 (load-scn (sc-number load-sc)))
1191 (setf (svref costs load-scn) 0)
1192 (setf (svref load-scs load-scn) t)
1193 (dolist (op-sc (append (when load-p
1194 (sc-constant-scs load-sc))
1195 (sc-alternate-scs load-sc)))
1196 (let* ((op-scn (sc-number op-sc))
1197 (load (if load-p
1198 (aref (sc-load-costs load-sc) op-scn)
1199 (aref (sc-load-costs op-sc) load-scn))))
1200 (unless load
1201 (error "No move function defined to move ~:[from~;to~] SC ~
1202 ~S~%~:[to~;from~] alternate or constant SC ~S."
1203 load-p sc-name load-p (sc-name op-sc)))
1204
1205 (let ((op-cost (svref costs op-scn)))
1206 (when (or (not op-cost) (< load op-cost))
1207 (setf (svref costs op-scn) load)))
1208
1209 (let ((op-load (svref load-scs op-scn)))
1210 (unless (eq op-load t)
1211 (pushnew load-scn (svref load-scs op-scn))))))
1212
1213 (dotimes (i sc-number-limit)
1214 (unless (svref costs i)
1215 (let ((op-sc (svref (backend-meta-sc-numbers *target-backend*) i)))
1216 (when op-sc
1217 (let ((cost (if load-p
1218 (svref (sc-move-costs load-sc) i)
1219 (svref (sc-move-costs op-sc) load-scn))))
1220 (when cost
1221 (setf (svref costs i) cost)))))))))
1222
1223 (values costs load-scs)))
1224
1225 (defparameter no-costs
1226 (make-array sc-number-limit :initial-element 0))
1227
1228 (defparameter no-loads
1229 (make-array sc-number-limit :initial-element 't))
1230
1231
1232 ;;; COMPUTE-LOADING-COSTS-IF-ANY -- Internal
1233 ;;;
1234 ;;; Pick off the case of operands with no restrictions.
1235 ;;;
1236 (defun compute-loading-costs-if-any (op load-p)
1237 (declare (type operand-parse op))
1238 (if (operand-parse-scs op)
1239 (compute-loading-costs op load-p)
1240 (values no-costs no-loads)))
1241
1242 ;;; COMPUTE-COSTS-AND-RESTRICTIONS-LIST -- Internal
1243 ;;;
1244 (defun compute-costs-and-restrictions-list (ops load-p)
1245 (declare (list ops))
1246 (collect ((costs)
1247 (scs))
1248 (dolist (op ops)
1249 (multiple-value-bind (costs scs)
1250 (compute-loading-costs-if-any op load-p)
1251 (costs costs)
1252 (scs scs)))
1253 (values (costs) (scs))))
1254
1255 ;;; Make-Costs-And-Restrictions -- Internal
1256 ;;;
1257 (defun make-costs-and-restrictions (parse)
1258 (multiple-value-bind
1259 (arg-costs arg-scs)
1260 (compute-costs-and-restrictions-list (vop-parse-args parse) t)
1261 (multiple-value-bind
1262 (result-costs result-scs)
1263 (compute-costs-and-restrictions-list (vop-parse-results parse) nil)
1264 `(
1265 :cost ,(vop-parse-cost parse)
1266
1267 :arg-costs ',arg-costs
1268 :arg-load-scs ',arg-scs
1269 :result-costs ',result-costs
1270 :result-load-scs ',result-scs
1271
1272 :more-arg-costs
1273 ',(if (vop-parse-more-args parse)
1274 (compute-loading-costs-if-any (vop-parse-more-args parse) t)
1275 nil)
1276
1277 :more-result-costs
1278 ',(if (vop-parse-more-results parse)
1279 (compute-loading-costs-if-any (vop-parse-more-results parse) nil)
1280 nil)))))
1281
1282
1283 ;;;; Operand checking and stuff:
1284
1285 ;;; PARSE-OPERAND-TYPES -- Internal
1286 ;;;
1287 ;;; Given a list of arg/result restrictions, check for valid syntax and
1288 ;;; convert to canonical form.
1289 ;;;
1290 (defun parse-operand-types (specs args-p)
1291 (declare (list specs))
1292 (labels ((parse-operand-type (spec)
1293 (cond ((eq spec '*) spec)
1294 ((symbolp spec)
1295 (let ((alias (gethash spec
1296 (backend-primitive-type-aliases
1297 *target-backend*))))
1298 (if alias
1299 (parse-operand-type alias)
1300 `(:or ,spec))))
1301 ((atom spec)
1302 (error "Bad thing to be a operand type: ~S." spec))
1303 (t
1304 (case (first spec)
1305 (:or
1306 (collect ((results))
1307 (results :or)
1308 (dolist (item (cdr spec))
1309 (unless (symbolp item)
1310 (error "Bad PRIMITIVE-TYPE name in ~S: ~S"
1311 spec item))
1312 (let ((alias
1313 (gethash item
1314 (backend-primitive-type-aliases
1315 *target-backend*))))
1316 (if alias
1317 (let ((alias (parse-operand-type alias)))
1318 (unless (eq (car alias) :or)
1319 (error "Can't include primitive-type ~
1320 alias ~S in a :OR restriction: ~S."
1321 item spec))
1322 (dolist (x (cdr alias))
1323 (results x)))
1324 (results item))))
1325 (remove-duplicates (results)
1326 :test #'eq
1327 :start 1)))
1328 (:constant
1329 (unless args-p
1330 (error "Can't :CONSTANT for a result."))
1331 (unless (= (length spec) 2)
1332 (error "Bad :CONSTANT argument type spec: ~S." spec))
1333 spec)
1334 (t
1335 (error "Bad thing to be a operand type: ~S." spec)))))))
1336 (mapcar #'parse-operand-type specs)))
1337
1338
1339 ;;; CHECK-OPERAND-TYPE-SCS -- Internal
1340 ;;;
1341 ;;; Check the consistency of Op's Sc restrictions with the specified
1342 ;;; primitive-type restriction. :CONSTANT operands have already been filtered
1343 ;;; out, so only :OR and * restrictions are left.
1344 ;;;
1345 ;;; We check that every representation allowed by the type can be directly
1346 ;;; loaded into some SC in the restriction, and that the type allows every SC
1347 ;;; in the restriction. With *, we require that T satisfy the first test, and
1348 ;;; omit the second.
1349 ;;;
1350 (defun check-operand-type-scs (parse op type load-p)
1351 (declare (type vop-parse parse) (type operand-parse op))
1352 (let ((ptypes (if (eq type '*) (list 't) (rest type)))
1353 (scs (operand-parse-scs op)))
1354 (when scs
1355 (multiple-value-bind (costs load-scs)
1356 (compute-loading-costs op load-p)
1357 (declare (ignore costs))
1358 (dolist (ptype ptypes)
1359 (unless (dolist (rep (primitive-type-scs
1360 (meta-primitive-type-or-lose ptype))
1361 nil)
1362 (when (svref load-scs rep) (return t)))
1363 (error "In the ~A ~:[result~;argument~] to VOP ~S,~@
1364 none of the SCs allowed by the operand type ~S can ~
1365 directly be loaded~@
1366 into any of the restriction's SCs:~% ~S~:[~;~@
1367 [* type operand must allow T's SCs.]~]"
1368 (operand-parse-name op) load-p (vop-parse-name parse)
1369 ptype
1370 scs (eq type '*)))))
1371
1372 (dolist (sc scs)
1373 (unless (or (eq type '*)
1374 (dolist (ptype ptypes nil)
1375 (when (meta-sc-allowed-by-primitive-type
1376 (meta-sc-or-lose sc)
1377 (meta-primitive-type-or-lose ptype))
1378 (return t))))
1379 (warn "~:[Result~;Argument~] ~A to VOP ~S~@
1380 has SC restriction ~S which is ~
1381 not allowed by the operand type:~% ~S"
1382 load-p (operand-parse-name op) (vop-parse-name parse)
1383 sc type)))))
1384
1385 (undefined-value))
1386
1387 ;;; Check-Operand-Types -- Internal
1388 ;;;
1389 ;;; If the operand types are specified, then check the number specified
1390 ;;; against the number of defined operands.
1391 ;;;
1392 (defun check-operand-types (parse ops more-op types load-p)
1393 (declare (type vop-parse parse) (list ops)
1394 (type (or list (member :unspecified)) types)
1395 (type (or operand-parse null) more-op))
1396 (unless (eq types :unspecified)
1397 (let ((num (+ (length ops) (if more-op 1 0))))
1398 (unless (= (count-if-not #'(lambda (x)
1399 (and (consp x)
1400 (eq (car x) :constant)))
1401 types)
1402 num)
1403 (error "Expected ~D ~:[result~;argument~] type~P: ~S."
1404 num load-p types num)))
1405
1406 (when more-op
1407 (let ((mtype (car (last types))))
1408 (when (and (consp mtype) (eq (first mtype) :constant))
1409 (error "Can't use :CONSTANT on VOP more args.")))))
1410
1411 (when (vop-parse-translate parse)
1412 (let ((types (specify-operand-types types ops more-op)))
1413 (mapc #'(lambda (x y)
1414 (check-operand-type-scs parse x y load-p))
1415 (if more-op (butlast ops) ops)
1416 (remove-if #'(lambda (x)
1417 (and (consp x)
1418 (eq (car x) ':constant)))
1419 (if more-op (butlast types) types)))))
1420
1421 (undefined-value))
1422
1423 ;;; Grovel-Operands -- Internal
1424 ;;;
1425 ;;; Compute stuff that can only be computed after we are done parsing
1426 ;;; everying. We set the VOP-Parse-Operands, and do various error checks.
1427 ;;;
1428 (defun grovel-operands (parse)
1429 (declare (type vop-parse parse))
1430
1431 (setf (vop-parse-operands parse)
1432 (append (vop-parse-args parse)
1433 (if (vop-parse-more-args parse)
1434 (list (vop-parse-more-args parse)))
1435 (vop-parse-results parse)
1436 (if (vop-parse-more-results parse)
1437 (list (vop-parse-more-results parse)))
1438 (vop-parse-temps parse)))
1439
1440 (check-operand-types parse
1441 (vop-parse-args parse)
1442 (vop-parse-more-args parse)
1443 (vop-parse-arg-types parse)
1444 t)
1445
1446
1447 (check-operand-types parse
1448 (vop-parse-results parse)
1449 (vop-parse-more-results parse)
1450 (vop-parse-result-types parse)
1451 nil)
1452
1453 (undefined-value))
1454
1455
1456 ;;;; Function translation stuff.
1457
1458 ;;; Make-Operand-Type -- Internal
1459 ;;;
1460 ;;; Return a form that can be evaluated to get the TEMPLATE operand type
1461 ;;; restriction from the given specification.
1462 ;;;
1463 (defun make-operand-type (type)
1464 (cond ((eq type '*) ''*)
1465 ((symbolp type)
1466 ``(:or ,(primitive-type-or-lose ',type)))
1467 (t
1468 (ecase (first type)
1469 (:or
1470 ``(:or ,,@(mapcar #'(lambda (type)
1471 `(primitive-type-or-lose ',type))
1472 (rest type))))
1473 (:constant
1474 ``(:constant ,#'(lambda (x)
1475 (typep x ',(second type)))
1476 ,',(second type)))))))
1477
1478
1479 ;;; Specify-Operand-Types -- Internal
1480 ;;;
1481 (defun specify-operand-types (types ops more-ops)
1482 (if (eq types :unspecified)
1483 (make-list (+ (length ops) (if more-ops 1 0)) :initial-element '*)
1484 types))
1485
1486 ;;; Make-VOP-Info-Types -- Internal
1487 ;;;
1488 ;;; Return a list of forms to use as keyword args to Make-VOP-Info for
1489 ;;; setting up the template argument and result types. Here we make an initial
1490 ;;; dummy Template-Type, since it is awkward to compute the type until the
1491 ;;; template has been made.
1492 ;;;
1493 (defun make-vop-info-types (parse)
1494 (let* ((more-args (vop-parse-more-args parse))
1495 (all-args (specify-operand-types (vop-parse-arg-types parse)
1496 (vop-parse-args parse)
1497 more-args))
1498 (args (if more-args (butlast all-args) all-args))
1499 (more-arg (when more-args (car (last all-args))))
1500 (more-results (vop-parse-more-results parse))
1501 (all-results (specify-operand-types (vop-parse-result-types parse)
1502 (vop-parse-results parse)
1503 more-results))
1504 (results (if more-results (butlast all-results) all-results))
1505 (more-result (when more-results (car (last all-results))))
1506 (conditional (vop-parse-conditional-p parse)))
1507
1508 `(
1509 :type (specifier-type '(function () nil))
1510 :arg-types (list ,@(mapcar #'make-operand-type args))
1511 :more-args-type ,(when more-args (make-operand-type more-arg))
1512 :result-types ,(if conditional
1513 :conditional
1514 `(list ,@(mapcar #'make-operand-type results)))
1515 :more-results-type ,(when more-results
1516 (make-operand-type more-result)))))
1517
1518
1519 ;;;; Set up VOP-Info:
1520
1521 (defconstant slot-inherit-alist
1522 '((:generator-function . vop-info-generator-function)))
1523
1524 ;;; Inherit-VOP-Info -- Internal
1525 ;;;
1526 ;;; Something to help with inheriting VOP-Info slots. We return a
1527 ;;; keyword/value pair that can be passed to the constructor. Slot is the
1528 ;;; keyword name of the slot, Parse is a form that evaluates to the VOP-Parse
1529 ;;; structure for the VOP inherited. If Parse is NIL, then we do nothing. If
1530 ;;; the Test form evaluates to true, then we return a form that selects the
1531 ;;; named slot from the VOP-Info structure corresponding to Parse. Otherwise,
1532 ;;; we return the Form so that the slot is recomputed.
1533 ;;;
1534 (defmacro inherit-vop-info (slot parse test form)
1535 `(if (and ,parse ,test)
1536 (list ,slot `(,',(or (cdr (assoc slot slot-inherit-alist))
1537 (error "Unknown slot ~S." slot))
1538 (template-or-lose ',(vop-parse-name ,parse))))
1539 (list ,slot ,form)))
1540
1541 ;;; Set-Up-VOP-Info -- Internal
1542 ;;;
1543 ;;; Return a form that creates a VOP-Info structure which describes VOP.
1544 ;;;
1545 (defun set-up-vop-info (iparse parse)
1546 (declare (type vop-parse parse) (type (or vop-parse null) iparse))
1547 (let ((same-operands
1548 (and iparse
1549 (equal (vop-parse-operands parse)
1550 (vop-parse-operands iparse))
1551 (equal (vop-parse-info-args iparse)
1552 (vop-parse-info-args parse))))
1553 (variant (vop-parse-variant parse)))
1554
1555 (let ((nvars (length (vop-parse-variant-vars parse))))
1556 (unless (= (length variant) nvars)
1557 (error "Expected ~D variant values: ~S." nvars variant)))
1558
1559 `(make-vop-info
1560 :name ',(vop-parse-name parse)
1561 ,@(make-vop-info-types parse)
1562 :guard ,(when (vop-parse-guard parse)
1563 `#'(lambda () ,(vop-parse-guard parse)))
1564 :note ',(vop-parse-note parse)
1565 :info-arg-count ,(length (vop-parse-info-args parse))
1566 :policy ',(vop-parse-policy parse)
1567 :save-p ',(vop-parse-save-p parse)
1568 :move-args ',(vop-parse-move-args parse)
1569 :effects (vop-attributes ,@(vop-parse-effects parse))
1570 :affected (vop-attributes ,@(vop-parse-affected parse))
1571 ,@(make-costs-and-restrictions parse)
1572 ,@(make-emit-function-and-friends parse)
1573 ,@(inherit-vop-info :generator-function iparse
1574 (and same-operands
1575 (equal (vop-parse-body parse) (vop-parse-body iparse)))
1576 (unless (eq (vop-parse-body parse) :unspecified)
1577 (make-generator-function parse)))
1578 :variant (list ,@variant))))
1579
1580
1581
1582 ;;; Define-VOP -- Public
1583 ;;;
1584 ;;; Parse the syntax into a VOP-Parse structure, and then expand into code
1585 ;;; that creates the appropriate VOP-Info structure at load time. We implement
1586 ;;; inheritance by copying the VOP-Parse structure for the inherited structure.
1587 ;;;
1588 (defmacro define-vop ((name &optional inherits) &rest specs)
1589 "Define-VOP (Name [Inherits]) Spec*
1590 Define the symbol Name to be a Virtual OPeration in the compiler. If
1591 specified, Inherits is the name of a VOP that we default unspecified
1592 information from. Each Spec is a list beginning with a keyword indicating
1593 the interpretation of the other forms in the Spec:
1594
1595 :Args {(Name {Key Value}*)}*
1596 :Results {(Name {Key Value}*)}*
1597 The Args and Results are specifications of the operand TNs passed to the
1598 VOP. If there is an inherited VOP, any unspecified options are defaulted
1599 from the inherited argument (or result) of the same name. The following
1600 operand options are defined:
1601
1602 :SCs (SC*)
1603 :SCs specifies good SCs for this operand. Other SCs will be
1604 penalized according to move costs. A load TN will be allocated if
1605 necessary, guaranteeing that the operand is always one of the
1606 specified SCs.
1607
1608 :Load-TN Load-Name
1609 Load-Name is bound to the load TN allocated for this operand, or to
1610 NIL if no load TN was allocated.
1611
1612 :Load-If Expression
1613 Controls whether automatic operand loading is done. Expression is
1614 evaluated with the fixed operand TNs bound. If Expression is true,
1615 then loading is done and the variable is bound to the load TN in
1616 the generator body. Otherwise, loading is not done, and the variable
1617 is bound to the actual operand.
1618
1619 :More T-or-NIL
1620 If specified, Name is bound to the TN-Ref for the first argument or
1621 result following the fixed arguments or results. A more operand must
1622 appear last, and cannot be targeted or restricted.
1623
1624 :Target Operand
1625 This operand is targeted to the named operand, indicating a desire to
1626 pack in the same location. Not legal for results.
1627
1628 :From Time-Spec
1629 :To Time-Spec
1630 Specify the beginning or end of the operand's lifetime. :From can
1631 only be used with results, and :To only with arguments. The default
1632 for the N'th argument/result is (:ARGUMENT N)/(:RESULT N). These
1633 options are necessary primarily when operands are read or written out
1634 of order.
1635
1636 :Conditional
1637 This is used in place of :RESULTS with conditional branch VOPs. There
1638 are no result values: the result is a transfer of control. The target
1639 label is passed as the first :INFO arg. The second :INFO arg is true if
1640 the sense of the test should be negated. A side-effect is to set the
1641 PREDICATE attribute for functions in the :TRANSLATE option.
1642
1643 :Temporary ({Key Value}*) Name*
1644 Allocate a temporary TN for each Name, binding that variable to the TN
1645 within the body of the generators. In addition to :Target (which is
1646 is the same as for operands), the following options are
1647 defined:
1648
1649 :SC SC-Name
1650 :Offset SB-Offset
1651 Force the temporary to be allocated in the specified SC with the
1652 specified offset. Offset is evaluated at macroexpand time. If
1653 Offset is emitted, the register allocator chooses a free location in
1654 SC. If both SC and Offset are omitted, then the temporary is packed
1655 according to its primitive type.
1656
1657 :From Time-Spec
1658 :To Time-Spec
1659 Similar to the argument/result option, this specifies the start and
1660 end of the temporarys' lives. The defaults are :Load and :Save, i.e.
1661 the duration of the VOP. The other intervening phases are :Argument,
1662 :Eval and :Result. Non-zero sub-phases can be specified by a list,
1663 e.g. by default the second argument's life ends at (:Argument 1).
1664
1665 :Generator Cost Form*
1666 Specifies the translation into assembly code. Cost is the estimated cost
1667 of the code emitted by this generator. The body is arbitrary Lisp code
1668 that emits the assembly language translation of the VOP. An Assemble
1669 form is wrapped around the body, so code may be emitted by using the
1670 local Inst macro. During the evaluation of the body, the names of the
1671 operands and temporaries are bound to the actual TNs.
1672
1673 :Effects Effect*
1674 :Affected Effect*
1675 Specifies the side effects that this VOP has and the side effects that
1676 effect its execution. If unspecified, these default to the worst case.
1677
1678 :Info Name*
1679 Define some magic arguments that are passed directly to the code
1680 generator. The corresponding trailing arguments to VOP or %Primitive are
1681 stored in the VOP structure. Within the body of the generators, the
1682 named variables are bound to these values. Except in the case of
1683 :Conditional VOPs, :Info arguments cannot be specified for VOPS that are
1684 the direct translation for a function (specified by :Translate).
1685
1686 :Ignore Name*
1687 Causes the named variables to be declared IGNORE in the generator body.
1688
1689 :Variant Thing*
1690 :Variant-Vars Name*
1691 These options provide a way to parameterize families of VOPs that differ
1692 only trivially. :Variant makes the specified evaluated Things be the
1693 \"variant\" associated with this VOP. :Variant-Vars causes the named
1694 variables to be bound to the corresponding Things within the body of the
1695 generator.
1696
1697 :Variant-Cost Cost
1698 Specifies the cost of this VOP, overriding the cost of any inherited
1699 generator.
1700
1701 :Note {String | NIL}
1702 A short noun-like phrase describing what this VOP \"does\", i.e. the
1703 implementation strategy. If supplied, efficency notes will be generated
1704 when type uncertainty prevents :TRANSLATE from working. NIL inhibits any
1705 efficency note.
1706
1707 :Arg-Types {* | PType | (:OR PType*) | (:CONSTANT Type)}*
1708 :Result-Types {* | PType | (:OR PType*)}*
1709 Specify the template type restrictions used for automatic translation.
1710 If there is a :More operand, the last type is the more type. :CONSTANT
1711 specifies that the argument must be a compile-time constant of the
1712 specified Lisp type. The constant values of :CONSTANT arguments are
1713 passed as additional :INFO arguments rather than as :ARGS.
1714
1715 :Translate Name*
1716 This option causes the VOP template to be entered as an IR2 translation
1717 for the named functions.
1718
1719 :Policy {:Small | :Fast | :Safe | :Fast-Safe}
1720 Specifies the policy under which this VOP is the best translation.
1721
1722 :Guard Form
1723 Specifies a Form that is evaluated in the global environment. If
1724 form returns NIL, then emission of this VOP is prohibited even when
1725 all other restrictions are met.
1726
1727 :VOP-Var Name
1728 :Node-Var Name
1729 In the generator, bind the specified variable to the VOP or the Node that
1730 generated this VOP.
1731
1732 :Save-P {NIL | T | :Compute-Only | :Force-To-Stack}
1733 Indicates how a VOP wants live registers saved.
1734
1735 :Move-Args {NIL | :Full-Call | :Local-Call | :Known-Return}
1736 Indicates if and how the more args should be moved into a different
1737 frame."
1738 (check-type name symbol)
1739
1740 (let* ((iparse (when inherits
1741 (vop-parse-or-lose inherits)))
1742 (parse (if inherits
1743 (copy-vop-parse iparse)
1744 (make-vop-parse)))
1745 (n-res (gensym)))
1746 (setf (vop-parse-name parse) name)
1747 (setf (vop-parse-inherits parse) inherits)
1748
1749 (parse-define-vop parse specs)
1750 (grovel-operands parse)
1751
1752 `(progn
1753 (eval-when (compile load eval)
1754 (setf (gethash ',name (backend-parsed-vops *target-backend*))
1755 ',parse))
1756
1757 (let ((,n-res ,(set-up-vop-info iparse parse)))
1758 (setf (gethash ',name (backend-template-names *target-backend*))
1759 ,n-res)
1760 (setf (template-type ,n-res)
1761 (specifier-type (template-type-specifier ,n-res)))
1762 ,@(set-up-function-translation parse n-res))
1763 ',name)))
1764
1765
1766 ;;;; Emission macros:
1767
1768 ;;; Make-Operand-List -- Internal
1769 ;;;
1770 ;;; Return code to make a list of VOP arguments or results, linked by
1771 ;;; TN-Ref-Across. The first value is code, the second value is LET* forms,
1772 ;;; and the third value is a variable that evaluates to the head of the list,
1773 ;;; or NIL if there are no operands. Fixed is a list of forms that evaluate to
1774 ;;; TNs for the fixed operands. TN-Refs will be made for these operands
1775 ;;; according using the specified value of Write-P. More is an expression that
1776 ;;; evaluates to a list of TN-Refs that will be made the tail of the list. If
1777 ;;; it is constant NIL, then we don't bother to set the tail.
1778 ;;;
1779 (defun make-operand-list (fixed more write-p)
1780 (collect ((forms)
1781 (binds))
1782 (let ((n-head nil)
1783 (n-prev nil))
1784 (dolist (op fixed)
1785 (let ((n-ref (gensym)))
1786 (binds `(,n-ref (reference-tn ,op ,write-p)))
1787 (if n-prev
1788 (forms `(setf (tn-ref-across ,n-prev) ,n-ref))
1789 (setq n-head n-ref))
1790 (setq n-prev n-ref)))
1791
1792 (when more
1793 (let ((n-more (gensym)))
1794 (binds `(,n-more ,more))
1795 (if n-prev
1796 (forms `(setf (tn-ref-across ,n-prev) ,n-more))
1797 (setq n-head n-more))))
1798
1799 (values (forms) (binds) n-head))))
1800
1801
1802 ;;; Emit-Template -- Interface
1803 ;;;
1804 (defmacro emit-template (node block template args results &optional info)
1805 "Emit-Template Node Block Template Args Results [Info]
1806 Call the emit function for Template, linking the result in at the end of
1807 Block."
1808 (let ((n-first (gensym))
1809 (n-last (gensym)))
1810 (once-only ((n-node node)
1811 (n-block block)
1812 (n-template template))
1813 `(multiple-value-bind
1814 (,n-first ,n-last)
1815 (funcall (template-emit-function ,n-template)
1816 ,n-node ,n-block ,n-template ,args ,results
1817 ,@(when info `(,info)))
1818 (insert-vop-sequence ,n-first ,n-last ,n-block nil)))))
1819
1820
1821 ;;; VOP -- Interface
1822 ;;;
1823 (defmacro vop (name node block &rest operands)
1824 "VOP Name Node Block Arg* Info* Result*
1825 Emit the VOP (or other template) Name at the end of the IR2-Block Block,
1826 using Node for the source context. The interpretation of the remaining
1827 arguments depends on the number of operands of various kinds that are
1828 declared in the template definition. VOP cannot be used for templates that
1829 have more-args or more-results, since the number of arguments and results is
1830 indeterminate for these templates. Use VOP* instead.
1831
1832 Args and Results are the TNs that are to be referenced by the template
1833 as arguments and results. If the template has codegen-info arguments, then
1834 the appropriate number of Info forms following the Arguments are used for
1835 codegen info."
1836 (let* ((parse (vop-parse-or-lose name))
1837 (arg-count (length (vop-parse-args parse)))
1838 (result-count (length (vop-parse-results parse)))
1839 (info-count (length (vop-parse-info-args parse)))
1840 (noperands (+ arg-count result-count info-count))
1841 (n-node (gensym))
1842 (n-block (gensym))
1843 (n-template (gensym)))
1844
1845 (when (or (vop-parse-more-args parse) (vop-parse-more-results parse))
1846 (error "Cannot use VOP with variable operand count templates."))
1847 (unless (= noperands (length operands))
1848 (error "Called with ~D operands, but was expecting ~D."
1849 (length operands) noperands))
1850
1851 (multiple-value-bind
1852 (acode abinds n-args)
1853 (make-operand-list (subseq operands 0 arg-count) nil nil)
1854 (multiple-value-bind
1855 (rcode rbinds n-results)
1856 (make-operand-list (subseq operands (+ arg-count info-count)) nil t)
1857
1858 (collect ((ibinds)
1859 (ivars))
1860 (dolist (info (subseq operands arg-count (+ arg-count info-count)))
1861 (let ((temp (gensym)))
1862 (ibinds `(,temp ,info))
1863 (ivars temp)))
1864
1865 `(let* ((,n-node ,node)
1866 (,n-block ,block)
1867 (,n-template (template-or-lose ',name *backend*))
1868 ,@abinds
1869 ,@(ibinds)
1870 ,@rbinds)
1871 ,@acode
1872 ,@rcode
1873 (emit-template ,n-node ,n-block ,n-template ,n-args
1874 ,n-results
1875 ,@(when (ivars)
1876 `((list ,@(ivars)))))
1877 (undefined-value)))))))
1878
1879
1880 ;;; VOP* -- Interface
1881 ;;;
1882 (defmacro vop* (name node block args results &rest info)
1883 "VOP* Name Node Block (Arg* More-Args) (Result* More-Results) Info*
1884 Like VOP, but allows for emission of templates with arbitrary numbers of
1885 arguments, and for emission of templates using already-created TN-Ref lists.
1886
1887 The Arguments and Results are TNs to be referenced as the first arguments
1888 and results to the template. More-Args and More-Results are heads of TN-Ref
1889 lists that are added onto the end of the TN-Refs for the explicitly supplied
1890 operand TNs. The TN-Refs for the more operands must have the TN and Write-P
1891 slots correctly initialized.
1892
1893 As with VOP, the Info forms are evaluated and passed as codegen info
1894 arguments."
1895 (check-type args cons)
1896 (check-type results cons)
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 (fixed-args (butlast args))
1902 (fixed-results (butlast results))
1903 (n-node (gensym))
1904 (n-block (gensym))
1905 (n-template (gensym)))
1906
1907 (unless (or (vop-parse-more-args parse)
1908 (<= (length fixed-args) arg-count))
1909 (error "Too many fixed arguments."))
1910 (unless (or (vop-parse-more-results parse)
1911 (<= (length fixed-results) result-count))
1912 (error "Too many fixed results."))
1913 (unless (= (length info) info-count)
1914 (error "Expected ~D info args." info-count))
1915
1916 (multiple-value-bind
1917 (acode abinds n-args)
1918 (make-operand-list fixed-args (car (last args)) nil)
1919 (multiple-value-bind
1920 (rcode rbinds n-results)
1921 (make-operand-list fixed-results (car (last results)) t)
1922
1923 `(let* ((,n-node ,node)
1924 (,n-block ,block)
1925 (,n-template (template-or-lose ',name *backend*))
1926 ,@abinds
1927 ,@rbinds)
1928 ,@acode
1929 ,@rcode
1930 (emit-template ,n-node ,n-block ,n-template ,n-args ,n-results
1931 ,@(when info
1932 `((list ,@info))))
1933 (undefined-value))))))
1934
1935
1936 ;;;; Random macros:
1937
1938 ;;; SC-Case -- Public
1939 ;;;
1940 (defmacro sc-case (tn &rest forms)
1941 "SC-Case TN {({(SC-Name*) | SC-Name | T} Form*)}*
1942 Case off of TN's SC. The first clause containing TN's SC is evaulated,
1943 returning the values of the last form. A clause beginning with T specifies a
1944 default. If it appears, it must be last. If no default is specified, and no
1945 clause matches, then an error is signalled."
1946 (let ((n-sc (gensym))
1947 (n-tn (gensym)))
1948 (collect ((clauses))
1949 (do ((cases forms (rest cases)))
1950 ((null cases)
1951 (clauses `(t (error "Unknown SC to SC-Case for ~S:~% ~S" ,n-tn
1952 (sc-name (tn-sc ,n-tn))))))
1953 (let ((case (first cases)))
1954 (when (atom case)
1955 (error "Illegal SC-Case clause: ~S." case))
1956 (let ((head (first case)))
1957 (when (eq head t)
1958 (when (rest cases)
1959 (error "T case is not last in SC-Case."))
1960 (clauses `(t nil ,@(rest case)))
1961 (return))
1962 (clauses `((or ,@(mapcar #'(lambda (x)
1963 `(eql ,(meta-sc-number-or-lose x)
1964 ,n-sc))
1965 (if (atom head) (list head) head)))
1966 nil ,@(rest case))))))
1967
1968 `(let* ((,n-tn ,tn)
1969 (,n-sc (sc-number (tn-sc ,n-tn))))
1970 (cond ,@(clauses))))))
1971
1972
1973 ;;; SC-Is -- Interface
1974 ;;;
1975 (defmacro sc-is (tn &rest scs)
1976 "SC-Is TN SC*
1977 Returns true if TNs SC is any of the named SCs, false otherwise."
1978 (once-only ((n-sc `(sc-number (tn-sc ,tn))))
1979 `(or ,@(mapcar #'(lambda (x)
1980 `(eql ,n-sc ,(meta-sc-number-or-lose x)))
1981 scs))))
1982
1983 ;;; Do-IR2-Blocks -- Interface
1984 ;;;
1985 (defmacro do-ir2-blocks ((block-var component &optional result)
1986 &body forms)
1987 "Do-IR2-Blocks (Block-Var Component [Result]) Form*
1988 Iterate over the IR2 blocks in component, in emission order."
1989 `(do ((,block-var (block-info (component-head ,component))
1990 (ir2-block-next ,block-var)))
1991 ((null ,block-var) ,result)
1992 ,@forms))
1993
1994
1995 ;;; DO-LIVE-TNS -- Interface
1996 ;;;
1997 (defmacro do-live-tns ((tn-var live block &optional result) &body body)
1998 "DO-LIVE-TNS (TN-Var Live Block [Result]) Form*
1999 Iterate over all the TNs live at some point, with the live set represented by
2000 a local conflicts bit-vector and the IR2-Block containing the location."
2001 (let ((n-conf (gensym))
2002 (n-bod (gensym))
2003 (i (gensym))
2004 (ltns (gensym)))
2005 (once-only ((n-live live)
2006 (n-block block))
2007 `(block nil
2008 (flet ((,n-bod (,tn-var) ,@body))
2009 ;;
2010 ;; Do component-live TNs.
2011 (dolist (,tn-var (ir2-component-component-tns
2012 (component-info
2013 (block-component
2014 (ir2-block-block ,n-block)))))
2015 (,n-bod ,tn-var))
2016
2017 (let ((,ltns (ir2-block-local-tns ,n-block)))
2018 ;;
2019 ;; Do TNs always-live in this block and live :More TNs.
2020 (do ((,n-conf (ir2-block-global-tns ,n-block)
2021 (global-conflicts-next ,n-conf)))
2022 ((null ,n-conf))
2023 (when (or (eq (global-conflicts-kind ,n-conf) :live)
2024 (let ((,i (global-conflicts-number ,n-conf)))
2025 (and (eq (svref ,ltns ,i) :more)
2026 (not (zerop (sbit ,n-live ,i))))))
2027 (,n-bod (global-conflicts-tn ,n-conf))))
2028 ;;
2029 ;; Do TNs locally live in the designated live set.
2030 (dotimes (,i (ir2-block-local-tn-count ,n-block) ,result)
2031 (unless (zerop (sbit ,n-live ,i))
2032 (let ((,tn-var (svref ,ltns ,i)))
2033 (when (and ,tn-var (not (eq ,tn-var :more)))
2034 (,n-bod ,tn-var)))))))))))
2035
2036
2037 ;;; DO-ENVIRONMENT-IR2-BLOCKS -- Interface
2038 ;;;
2039 (defmacro do-environment-ir2-blocks ((block-var env &optional result)
2040 &body body)
2041 "DO-ENVIRONMENT-IR2-BLOCKS (Block-Var Env [Result]) Form*
2042 Iterate over all the IR2 blocks in the environment Env, in emit order."
2043 (once-only ((n-env env))
2044 (once-only ((n-first `(node-block
2045 (lambda-bind
2046 (environment-function ,n-env)))))
2047 (once-only ((n-tail `(block-info
2048 (component-tail
2049 (block-component ,n-first)))))
2050 `(do ((,block-var (block-info ,n-first)
2051 (ir2-block-next ,block-var)))
2052 ((or (eq ,block-var ,n-tail)
2053 (not (eq (ir2-block-environment ,block-var) ,n-env)))
2054 ,result)
2055 ,@body)))))
2056
2057

  ViewVC Help
Powered by ViewVC 1.1.5