/[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.8 - (show annotations)
Sat Dec 7 18:19:34 2002 UTC (11 years, 4 months ago) by toy
Branch: MAIN
CVS Tags: release-18e-base, release-18e-pre2, cold-pcl-base, release-18e, release-18e-pre1
Branch point for: release-18e-branch, cold-pcl
Changes since 1.7: +5 -3 lines
From Eric Marsden:

   - fixes to the internal consistency of IR2, ported from the
     corresponding changes to SBCL by Alexey Dejneka

   - modification of the internal IR1 consistency checking code to
     accept objects of type HEAP-ALIEN-INFO in the *FREE-VARIABLES*
     list.


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

  ViewVC Help
Powered by ViewVC 1.1.5