vmdef.lisp 77.2 KB
Newer Older
wlott's avatar
wlott committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;;    This file contains implementation-independent facilities used for
;;; defining the compiler's interface to the VM in a given implementation.
;;;
;;; Written by Rob MacLachlan
;;;
(in-package 'c)

;;;
;;; Translates from SC numbers to SC info structures.  SC numbers are always
;;; used instead of names at run time, so changing this vector changes all the
;;; references.
(defvar *sc-numbers* (make-array sc-number-limit))
(proclaim '(type sc-vector *sc-numbers*))

;;;
;;; A list of all the SBs defined, so that we can easily iterate over them.
(defvar *sb-list* ())
(proclaim '(type list *sb-list*))

;;;
;;; Translates from template names to template structures.
(defvar *template-names* (make-hash-table :test #'eq))
(proclaim '(type hash-table *template-names*))

;;; Template-Or-Lose  --  Internal
;;;
;;;    Return the template having the specified name, or die trying.
;;;
(defun template-or-lose (x)
  (the template
       (or (gethash x *template-names*)
	   (error "~S is not a defined template." x))))


(eval-when (compile load eval)

;;;
;;; Hashtable from SC and SB names the corresponding structures.  These tables
;;; are only used at meta-compile and load times, so the defining macros can
;;; change these at meta-compile time without breaking the compiler.
(defvar *sc-names* (make-hash-table :test #'eq))
(defvar *sb-names* (make-hash-table :test #'eq))
(proclaim '(hash-table *sc-names* *sb-names*))

;;;
;;; Like *SC-Numbers*, but is updated at meta-compile time.
(defvar *meta-sc-numbers* (make-array sc-number-limit))
(proclaim '(type sc-vector *meta-sc-numbers*))


;;; SC-Or-Lose, SB-Or-Lose, SC-Number-Or-Lose  --  Internal
;;;
;;;    Return the SC structure, SB structure or SC number corresponding to a
;;; name, or die trying.  These should not be used after load time, since
;;; compiling the compiler changes the definitions.
;;;
(defun sc-or-lose (x)
  (the sc
       (or (gethash x *sc-names*)
	   (error "~S is not a defined storage class." x))))
;;;
(defun sb-or-lose (x)
  (the sb
       (or (gethash x *sb-names*)
	   (error "~S is not a defined storage base." x))))
;;;
(defun sc-number-or-lose (x)
  (the sc-number (sc-number (sc-or-lose x))))

); Eval-When (Compile Load Eval)


;;;; Storage class and storage base definition:

;;; Define-Storage-Base  --  Public
;;;
;;;    Enter the basic structure at meta-compile time, and then fill in the
;;; missing slots at load time.
;;;
(defmacro define-storage-base (name kind &key size)
  "Define-Storage-Base Name Kind {Key Value}*
  Define a storage base having the specified Name.  Kind may be :Finite,
  :Unbounded or :Non-Packed.  The following keywords are legal:

  :Size <Size>
      Specify the number of locations in a :Finite SB or the initial size of a
      :Unbounded SB."
  (check-type name symbol)
  (check-type kind (member :finite :unbounded :non-packed))
  (ecase kind
    (:non-packed
     (when size
       (error "Size specification meaningless in a ~S SB." kind)))
    ((:finite :unbounded)
     (unless size (error "Size not specified in a ~S SB." kind))
     (check-type size unsigned-byte)))
    
  (let ((res (if (eq kind :non-packed)
		 (make-sb :name name :kind kind)
		 (make-finite-sb :name name :kind kind :size size))))
    `(progn
       (eval-when (compile load eval)
	 (setf (gethash ',name *sb-names*) ',res))
       ,(if (eq kind :non-packed)
	    `(setf (gethash ',name *sb-names*) (copy-sb ',res))
	    `(let ((res (copy-finite-sb ',res)))
	       (setf (finite-sb-always-live res)
		     (make-array ',size :initial-element #*))
	       (setf (finite-sb-conflicts res)
		     (make-array ',size :initial-element '#()))
	       (setf (finite-sb-live-tns res)
		     (make-array ',size :initial-element nil))
	       (setf (gethash ',name *sb-names*) res)))
       (setq *sb-list*
	     (cons (gethash ',name *sb-names*)
		   (remove ',name *sb-list* :key #'sb-name)))
       ',name)))


;;; Define-Storage-Class  --  Public
;;;
;;;
(defmacro define-storage-class (name number sb-name &key (element-size '1) 
ram's avatar
ram committed
133
134
				     locations save-p alternate-scs
				     constant-scs)
wlott's avatar
wlott committed
135
136
137
138
139
  "Define-Storage-Class Name Number Storage-Base {Key Value}*
  Define a storage class Name that uses the named Storage-Base.  Number is a
  small, non-negative integer that is used as an alias.  The following
  keywords are defined:

ram's avatar
ram committed
140
  :Element-Size Size
wlott's avatar
wlott committed
141
142
143
      The size of objects in this SC in whatever units the SB uses.  This
      defaults to 1.

ram's avatar
ram committed
144
  :Locations (Location*)
wlott's avatar
wlott committed
145
      If the SB is :Finite, then this is a list of the offsets within the SB
ram's avatar
ram committed
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
      that are in this SC.

  :Save-P {T | NIL}
      If T, then values stored in this SC must be saved in one of the
      non-save-p :Alternate-SCs across calls.

  :Alternate-SCs (SC*)
      Indicates other SCs that can be used to hold values from this SC across
      calls or when storage in this SC is exhausted.  The SCs should be
      specified in order of decreasing \"goodness\".  Unless this SC is only
      used for restricted or wired TNs, then there must be a last SC in an
      unbounded SB.

  :Constant-SCs (SC*)
      A list of the names of all the constant SCs that can be loaded into this
      SC by a load function."
wlott's avatar
wlott committed
162
163
164
165
166
  
  (check-type name symbol)
  (check-type number sc-number)
  (check-type sb-name symbol)
  (check-type locations list)
ram's avatar
ram committed
167
168
169
  (check-type save-p boolean)
  (check-type alternate-scs list)
  (check-type constant-scs list)
wlott's avatar
wlott committed
170
171
172
173
174
175
176
177
178
179
180

  (let ((sb (sb-or-lose sb-name)))
    (if (eq (sb-kind sb) :finite)
	(let ((size (sb-size sb))
	      (element-size (eval element-size)))
	  (check-type element-size unsigned-byte)
	  (dolist (el locations)
	    (check-type el unsigned-byte)
	    (unless (<= 1 (+ el element-size) size)
	      (error "SC element ~D out of bounds for ~S." el sb))))
	(when locations
ram's avatar
ram committed
181
182
183
184
185
186
187
188
	  (error ":Locations is meaningless in a ~S SB." (sb-kind sb))))

    (when (and (or alternate-scs constant-scs)
	       (eq (sb-kind sb) :non-packed))
      (error "Meaningless to specify alternate or constant SCs in a ~S SB."
	     (sb-kind sb))))

  (let ((nstack-p
189
190
191
	 (if (or (eq sb-name 'non-descriptor-stack)
		 (find 'non-descriptor-stack
		       (mapcar #'sc-or-lose alternate-scs)
ram's avatar
ram committed
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
		       :key #'(lambda (x)
				(sb-name (sc-sb x)))))
	     t nil)))
    `(progn
       (eval-when (compile load eval)
	 (let ((res (make-sc :name ',name :number ',number
			     :sb (sb-or-lose ',sb-name)
			     :element-size ,element-size
			     :locations ',locations
			     :save-p ',save-p
			     :number-stack-p ,nstack-p
			     :alternate-scs (mapcar #'sc-or-lose
						    ',alternate-scs)
			     :constant-scs (mapcar #'sc-or-lose
						   ',constant-scs))))
	   (setf (gethash ',name *sc-names*) res)
	   (setf (svref *meta-sc-numbers* ',number) res)
	   (setf (svref (sc-load-costs res) ',number) 0)))
       
       (let ((old (svref *sc-numbers* ',number)))
	 (when (and old (not (eq (sc-name old) ',name)))
	   (warn "Redefining SC number ~D from ~S to ~S." ',number
		 (sc-name old) ',name)))
       
       (setf (svref *sc-numbers* ',number) (sc-or-lose ',name))
       ',name)))
wlott's avatar
wlott committed
218

ram's avatar
ram committed
219
220

;;;; Move/coerce definition:
wlott's avatar
wlott committed
221
222


ram's avatar
ram committed
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
;;; DO-SC-PAIRS  --  Internal
;;;
;;;    Given a list of paris of lists of SCs (as given to DEFINE-MOVE-VOP,
;;; etc.), bind TO-SC and FROM-SC to all the combinations.
;;;
(eval-when (compile load eval)
  (defmacro do-sc-pairs ((from-sc-var to-sc-var scs) &body body)
    `(do ((froms ,scs (cddr froms))
	  (tos (cdr ,scs) (cddr tos)))
	 ((null froms))
       (dolist (from (car froms))
	 (let ((,from-sc-var (sc-or-lose from)))
	   (dolist (to (car tos))
	     (let ((,to-sc-var (sc-or-lose to)))
	       ,@body)))))))


;;; DEFINE-MOVE-FUNCTION  --  Public
;;;
(defmacro define-move-function ((name cost) lambda-list scs &body body)
  "Define-Move-Function (Name Cost) lambda-list ({(From-SC*) (To-SC*)}*) form*
  Define the function Name and note it as the function used for moving operands
  from the From-SCs to the To-SCs.  Cost is the cost of this move operation.
  The function is called with three arguments: the node (for source context),
  and the source and destination TNs.  An ASSEMBLE form is wrapped around the
  body.  All uses of DEFINE-MOVE-FUNCTION should be compiled before any uses of
  DEFINE-VOP."
  (when (or (oddp (length scs)) (null scs))
    (error "Malformed SCs spec: ~S." scs))
  (check-type cost index)
  `(progn
     (eval-when (compile load eval)
       (do-sc-pairs (from-sc to-sc ',scs)
	 (unless (eq from-sc to-sc)
	   (let ((num (sc-number from-sc)))
	     (setf (svref (sc-load-functions to-sc) num) ',name)
	     (setf (svref (sc-load-costs to-sc) num) ',cost)))))

     (defun ,name ,lambda-list
       (assemble ,(first lambda-list) ,@body))))


(defconstant sc-vop-slots '((:move . sc-move-vops)
			    (:move-argument . sc-move-arg-vops)))


;;; COMPUTE-MOVE-COSTS  --  Internal
;;;
;;;    Compute at meta-compile time the costs for moving between all SCs that
;;; can be loaded from FROM-SC and to TO-SC given a base move cost Cost.
;;;
(defun compute-move-costs (from-sc to-sc cost)
  (declare (type sc from-sc to-sc) (type index cost))
  (let ((to-scn (sc-number to-sc))
	(from-costs (sc-load-costs from-sc)))
    (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc)))
      (let ((vec (sc-move-costs dest-sc))
	    (dest-costs (sc-load-costs dest-sc)))
	(setf (svref vec (sc-number from-sc)) cost)
	(dolist (sc (append (sc-alternate-scs from-sc)
			    (sc-constant-scs from-sc)))
	  (let* ((scn (sc-number sc))
		 (total (+ (svref from-costs scn)
			   (svref dest-costs to-scn)
			   cost))
		 (old (svref vec scn)))
	    (unless (and old (< old total))
	      (setf (svref vec scn) total))))))))
    
    
;;; DEFINE-MOVE-VOP  --  Public
;;;
ram's avatar
ram committed
295
296
;;;    We record the VOP and costs for all SCs that we can move between
;;; (including implicit loading).
ram's avatar
ram committed
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
;;;
(defmacro define-move-vop (name kind &rest scs)
  "Define-Move-VOP Name {:Move | :Move-Argument} {(From-SC*) (To-SC*)}*
  Make Name be the VOP used to move values in the specified From-SCs to the
  representation of the To-SCs.  If kind is :Move-Argument, then the VOP takes
  an extra argument, which is the frame pointer of the frame to move into." 
  (when (or (oddp (length scs)) (null scs))
    (error "Malformed SCs spec: ~S." scs))
  (let ((accessor (or (cdr (assoc kind sc-vop-slots))
		      (error "Unknown kind ~S." kind))))
    `(progn
       ,@(when (eq kind :move)
	   `((eval-when (compile load eval)
	       (do-sc-pairs (from-sc to-sc ',scs)
		 (compute-move-costs from-sc to-sc
				     ,(vop-parse-cost
				       (vop-parse-or-lose name)))))))
       
       (let ((vop (template-or-lose ',name)))
	 (do-sc-pairs (from-sc to-sc ',scs)
	   (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc)))
	     (let ((vec (,accessor dest-sc)))
	       (setf (svref vec (sc-number from-sc)) vop)
	       (dolist (sc (append (sc-alternate-scs from-sc)
				   (sc-constant-scs from-sc)))
		 (let ((scn (sc-number sc)))
		   (unless (svref vec scn) 
		     (setf (svref vec scn) vop)))))))))))
wlott's avatar
wlott committed
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391


;;;; Primitive type definition:

;;; Translates from primitive type names to the corresponding primitive-type
;;; structure.
;;;
(defvar *primitive-type-names* (make-hash-table :test #'eq))

;;; The primitive type T is somewhat magical, in that it is the only primitive
;;; type that overlaps with other primitive types.  An object of primitive-type
;;; T is in the canonical descriptor (boxed or pointer) representation.
;;;
;;; We stick the T primitive-type in a variable so that people who have to
;;; special-case it can get at it conveniently.  This is done by the machine
;;; specific VM definition, since the Def-Primitive-Type for T must specify the
;;; SCs that boxed objects can be allocated in.
;;;
(proclaim '(special *any-primitive-type*))
(proclaim '(type primitive-type *any-primitive-type*))


;;; Def-Primitive-Type  --  Public
;;;
;;;    If the primitive-type structure already exists, we destructively modify
;;; it so that existing references in templates won't be invalidated.
;;; Primitive-type definition isn't done at meta-compile time, so this doesn't
;;; break the running compiler.
;;;
(defmacro def-primitive-type (name scs &key (type name))
  "Def-Primitive-Type Name (SC*) {Key Value}*
  Define a primitive type Name.  Each SC specifies a Storage Class that values
  of this type may be allocated in.  The following keyword options are defined:

  :Type
      The type descriptor for the Lisp type that is equivalent to this type
      (defaults to Name.)"
  (check-type name symbol)
  (check-type scs list)
  (once-only ((n-old `(gethash ',name *primitive-type-names*))
	      (n-scs `(mapcar #'sc-number-or-lose ',scs))
	      (n-type `(specifier-type ',type)))
    `(progn
       (cond (,n-old
	      (setf (primitive-type-scs ,n-old) ,n-scs)
	      (setf (primitive-type-type ,n-old) ,n-type))
	     (t
	      (setf (gethash ',name *primitive-type-names*)
		    (make-primitive-type :name ',name
					 :scs ,n-scs
					 :type ,n-type))))
       ',name)))


;;; Primitive-Type-Or-Lose  --  Interface
;;;
;;;    Return the primitive type corresponding to the spesicifed name, or die
;;; trying.
;;;
(defun primitive-type-or-lose (name)
  (the primitive-type
       (or (gethash name *primitive-type-names*)
	   (error "~S is not a defined primitive type." name))))


(eval-when (compile load eval)
  (defparameter primitive-type-slot-alist
ram's avatar
ram committed
392
    '((:check . primitive-type-check))))
wlott's avatar
wlott committed
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486


;;; Primitive-Type-Vop  --  Public
;;;
(defmacro primitive-type-vop (vop kinds &rest types)
  "Primitive-Type-VOP Vop (Kind*) Type*
  Annotate all the specified primitive Types with the named VOP under each of
  the specified kinds:

  :Check
      A one argument one result VOP that moves the argument to the result,
      checking that the value is of this type in the process."
  (let ((n-vop (gensym))
	(n-type (gensym)))
    `(let ((,n-vop (template-or-lose ',vop)))
       ,@(mapcar
	  #'(lambda (type)
	      `(let ((,n-type (primitive-type-or-lose ',type)))
		 ,@(mapcar
		    #'(lambda (kind)
			(let ((slot (or (cdr (assoc kind
						    primitive-type-slot-alist))
					(error "Unknown kind: ~S." kind))))
			  `(setf (,slot ,n-type) ,n-vop)))
		    kinds)))
	  types)
       nil)))


;;;; VOP definition structures:
;;;
;;;    Define-VOP uses some fairly complex data structures at meta-compile
;;; time, both to hold the results of parsing the elaborate syntax and to
;;; retain the information so that it can be inherited by other VOPs.

(eval-when (compile load eval)

;;;
;;; Hashtable translating from VOP names to the corresponding VOP-Parse
;;; structures.  This information is only used at meta-compile time.
(defvar *parsed-vops* (make-hash-table :test #'eq))
(proclaim '(type hash-table *parsed-vops*))

;;; The VOP-Parse structure holds everything we need to know about a VOP at
;;; meta-compile time.
;;;
(defstruct (vop-parse
	    (:print-function %print-vop-parse))
  ;;
  ;; The name of this VOP.
  (name nil :type symbol)
  ;;
  ;; If true, then the name of the VOP we inherit from.
  (inherits nil :type (or symbol null))
  ;;
  ;; Lists of Operand-Parse structures describing the arguments, results and
  ;; temporaries of the VOP.
  (args nil :type list)
  (results nil :type list)
  (temps nil :type list)
  ;;
  ;; Operand-Parse structures containing information about more args and
  ;; results.  If null, then there there are no more operands of that kind.
  (more-args nil :type (or operand-parse null))
  (more-results nil :type (or operand-parse null))
  ;;
  ;; A list of all the above together.
  (operands nil :type list)
  ;;
  ;; Names of variables that should be declared ignore.
  (ignores () :type list)
  ;;
  ;; True if this is a :Conditional VOP.
  (conditional-p nil)
  ;;
  ;; Argument and result primitive types.  These are pulled out of the
  ;; operands, since we often want to change them without respecifying the
  ;; operands.
  (arg-types :unspecified :type (or (member :unspecified) list))
  (result-types :unspecified :type (or (member :unspecified) list))
  ;;
  ;; The guard expression specified, or NIL if none.
  (guard nil)
  ;;
  ;; The cost of and body code for the generator.
  (cost 0 :type unsigned-byte)
  (body :unspecified :type (or (member :unspecified) list))
  ;;
  ;; Info for VOP variants.  The list of forms to be evaluated to get the
  ;; variant args for this VOP, and the list of variables to be bound to the
  ;; variant args.
  (variant () :type list)
  (variant-vars () :type list)
  ;;
487
488
  ;; Variables bound to the VOP and Vop-Node when in the generator body.
  (vop-var (gensym) :type symbol)
wlott's avatar
wlott committed
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
  (node-var nil :type (or symbol null))
  ;;
  ;; A list of the names of the codegen-info arguments to this VOP.
  (info-args () :type list)
  ;;
  ;; An efficiency note associated with this VOP.
  (note nil :type (or string null))
  ;;
  ;; A list of the names of the Effects and Affected attributes for this VOP.
  (effects '(any) :type list)
  (affected '(any) :type list)
  ;;
  ;; A list of the names of functions this VOP is a translation of and the
  ;; policy that allows this translation to be done.  :Fast is a safe default,
  ;; since it isn't a safe policy.
  (translate () :type list)
  (policy :fast :type policies)
  ;;
  ;; Stuff used by life analysis.
ram's avatar
ram committed
508
509
510
511
512
513
  (save-p nil :type (member t nil :compute-only :force-to-stack))
  ;;
  ;; Info about how to emit move-argument VOPs for the more operand in
  ;; call/return VOPs.
  (move-args nil :type (member nil :local-call :full-call :known-return)))

wlott's avatar
wlott committed
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535

(defprinter vop-parse
  name
  (inherits :test inherits)
  args
  results
  temps
  (more-args :test more-args)
  (more-results :test more-results)
  (conditional-p :test conditional-p)
  ignores
  arg-types
  result-types
  cost
  body
  (variant :test variant)
  (variant-vars :test variant-vars)
  (info-args :test info-args)
  (note :test note)
  effects
  affected
  translate
ram's avatar
ram committed
536
537
538
  policy
  (save-p :test save-p)
  (move-args :test move-args))
wlott's avatar
wlott committed
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571

;;; The Operand-Parse structure contains stuff we need to know about and
;;; operand or temporary at meta-compile time.  Besides the obvious stuff, we
;;; also store the names of per-operand temporaries here.
;;;
(defstruct (operand-parse
	    (:print-function %print-operand-parse))
  ;;
  ;; Name of the operand (which we bind to the TN).
  (name nil :type symbol)
  ;;
  ;; The way this operand is used:
  (kind nil :type (member :argument :result :temporary
			  :more-argument :more-result))
  ;;
  ;; If true, the name of an operand that this operand is targeted to.  This is
  ;; only meaningful in :Argument and :Temporary operands.
  (target nil :type (or symbol null))
  ;;
  ;; Temporary that holds the TN-Ref for this operand.  Temp-Temp holds the
  ;; write reference that begins a temporary's lifetime.
  (temp (gensym) :type symbol)
  (temp-temp nil :type (or symbol null))
  ;;
  ;; The time that this operand is first live and the time at which it becomes
  ;; dead again.  These are time-specs, as returned by parse-time-spec. 
  born
  dies
  ;;
  ;; A list of the names of the SCs that this operand is allowed into.  If
  ;; false, there is no restriction.
  (scs nil :type list)
  ;;
ram's avatar
ram committed
572
573
574
  ;; Variable that is bound to the load TN allocated for this operand, or to
  ;; NIL if no load-TN was allocated.
  (load-tn (gensym) :type symbol)
wlott's avatar
wlott committed
575
  ;;
ram's avatar
ram committed
576
577
578
  ;; If true, automatic operand loading is inhibited and the operand name is
  ;; always bound to the original TN.
  (load t :type boolean)
wlott's avatar
wlott committed
579
  ;;
ram's avatar
ram committed
580
581
  ;; In a wired or restricted temporary this is the SC the TN is to be packed
  ;; in.  Null otherwise.
wlott's avatar
wlott committed
582
  (sc nil :type (or symbol null))
ram's avatar
ram committed
583
584
  ;;
  ;; If non-null, we are a temp wired to this offset in SC.
wlott's avatar
wlott committed
585
586
587
588
589
590
591
592
593
594
  (offset nil :type (or unsigned-byte null)))


(defprinter operand-parse
  name
  kind
  (target :test target)
  born
  dies
  (scs :test scs)
ram's avatar
ram committed
595
  (load :test load)
wlott's avatar
wlott committed
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
  (sc :test sc)
  (offset :test offset))

); Eval-When (Compile Load Eval)


;;;; Random utilities:

(eval-when (compile load eval)

;;; Find-Operand  --  Internal
;;;
;;;    Find the operand or temporary with the specifed Name in the VOP Parse.
;;; If there is no such operand, signal an error.  Also error if the operand
;;; kind isn't one of the specified Kinds.
;;;
(defun find-operand (name parse &optional
			  (kinds '(:argument :result :temporary)))
  (declare (symbol name) (type vop-parse parse) (list kinds))
  (let ((found (find name (vop-parse-operands parse)
		     :key #'operand-parse-name)))
    (unless found
      (error "~S is not an operand to ~S." name (vop-parse-name parse)))
    (unless (member (operand-parse-kind found) kinds)
      (error "Operand ~S isn't one of these kinds: ~S." name kinds))
    found))


;;; VOP-Parse-Or-Lose  --  Internal
;;;
;;;    Get the VOP-Parse structure for Name or die trying.  For all
;;; meta-compile time uses, the VOP-Parse should be used instead of the
;;; VOP-Info
;;;
(defun vop-parse-or-lose (name)
  (the vop-parse
       (or (gethash name *parsed-vops*)
	   (error "~S is not the name of a defined VOP." name))))


;;; Access-Operands  --  Internal
;;;
;;;    Return a list of let-forms to parse a tn-ref list into a the temps
;;; specified by the operand-parse structures.  More-Operand is the
;;; Operand-Parse describing any more operand, or NIL if none.  Refs is an
;;; expression that evaluates into the first tn-ref.
;;;
(defun access-operands (operands more-operand refs)
644
  (declare (list operands))
wlott's avatar
wlott committed
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
  (collect ((res))
    (let ((prev refs))
      (dolist (op operands)
	(let ((n-ref (operand-parse-temp op)))
	  (res `(,n-ref ,prev))
	  (setq prev `(tn-ref-across ,n-ref))))

      (when more-operand
	(res `(,(operand-parse-name more-operand) ,prev))))
    (res)))


;;; Ignore-Unreferenced-Temps --  Internal
;;;
;;;    Used with Access-Operands to prevent warnings for TN-Ref temps not used
;;; by some particular function.  It returns the name of the last operand, or
;;; NIL if Operands is NIL.
;;;
(defun ignore-unreferenced-temps (operands)
  (when operands
    (operand-parse-temp (car (last operands)))))


;;; VOP-Spec-Arg  --  Internal
;;;
;;;    Grab an arg out of a VOP spec, checking the type and syntax and stuff.
;;;
(defun vop-spec-arg (spec type &optional (n 1) (last t))
  (let ((len (length spec)))
    (when (<= len n)
      (error "~:R argument missing: ~S." n spec))
    (when (and last (> len (1+ n)))
      (error "Extra junk at end of ~S." spec))
    (let ((thing (elt spec n)))
      (unless (typep thing type)
	(error "~:R argument is not a ~S: ~S." n type spec))
      thing)))


;;;; Time specs:

;;; Parse-Time-Spec  --  Internal
;;;
;;;    Return a time spec describing a time during the evaluation of a VOP,
;;; used to delimit operand and temporary lifetimes.  The representation is a
;;; cons whose CAR is the number of the evaluation phase and the CDR is the
;;; sub-phase.  The sub-phase is 0 in the :Load and :Save phases. 
;;;
(defun parse-time-spec (spec)
  (let ((dspec (if (atom spec) (list spec 0) spec)))
    (unless (and (= (length dspec) 2)
		 (typep (second dspec) 'unsigned-byte))
      (error "Malformed time specifier: ~S." spec))

    (cons (case (first dspec)
	    (:load 0)
	    (:argument 1)
	    (:eval 2)
	    (:result 3)
	    (:save 4)
	    (t
	     (error "Unknown phase in time specifier: ~S." spec)))
	  (second dspec))))


;;; Time-Spec-Order  --  Internal
;;;
;;;    Return true if the time spec X is the same or later time than Y.
;;;
(defun time-spec-order (x y)
  (or (> (car x) (car y))
      (and (= (car x) (car y))
	   (>= (cdr x) (cdr y)))))
 

;;;; Emit function generation:

;;; Compute-Reference-Order  --  Internal
;;;
;;;    Return a list of 2-lists (<Temporary> <More-P>) in reverse reference
;;; order describing how to build the next-ref linkage for Parse.  If More-P is
;;; false, then the Temporary points to a single TN-Ref that should be linked
;;; in.  If More-P is true, then Temporary points to a chain of Tn-Refs linked
;;; together by Tn-Ref-Across that should be linked in reverse order.
;;;
;;;    In implementation, we build a temporary list containing the result
;;; tuples augmented with reference time and whether the reference is a write.
;;; We sort this list using Time-Spec-Order augmented by the subsidiary rule
;;; that when the specs are equal, we do read references first.  This
;;; implements the desired semantics of open intervals for temporary lifetimes.
;;;
(defun compute-reference-order (parse)
  (declare (type vop-parse parse))
  (collect ((refs))
    (dolist (op (vop-parse-operands parse))
      (let ((born (operand-parse-born op))
	    (dies (operand-parse-dies op))
	    (name (operand-parse-name op))
	    (temp (operand-parse-temp op))
	    (temp-temp (operand-parse-temp-temp op)))
	(ecase (operand-parse-kind op)
	  (:argument
	   (refs (list (cons dies nil) temp nil)))
	  (:more-argument
	   (refs (list (cons dies nil) name t)))
	  (:result
	   (refs (list (cons born t) temp nil)))
	  (:more-result
	   (refs (list (cons born t) name t)))
	  (:temporary
	   (refs (list (cons born t) temp nil))
	   (refs (list (cons dies nil) temp-temp nil))))))

    (mapcar #'cdr
	    (sort (refs)
		  #'(lambda (x y)
		      (let ((x-time (car x))
			    (y-time (car y)))
		      (if (time-spec-order x-time y-time)
			  (if (time-spec-order y-time x-time)
			      (or (cdr x) (not (cdr y)))
			      t)
			  nil)))
		  :key #'first))))


;;; Make-Next-Ref-Linkage  --  Internal
;;;
;;;    Use the operand lifetime annotations to set up the next-ref slots in all
;;; the TN-Refs used in the VOP.  We set the Refs in the VOP to point to the
;;; head of this list.  More operands make life a bit interesting, since they
;;; introduce uncertainty as to whether we have seen any operands yet, and also
;;; must be linked together contiguously with the other TN-Refs.
;;;
(defun make-next-ref-linkage (parse n-vop)
  (declare (type vop-parse parse))
  (collect ((forms)
	    (binds))
    (let ((first-seen :no)
	  (prev nil))
      (dolist (x (compute-reference-order parse))
	(let* ((var (first x))
	       (more-p (second x))
	       (n-tail (if more-p (gensym) var)))
	  (ecase first-seen
	    (:no
	     (forms `(setf (vop-refs ,n-vop) ,n-tail)))
	    (:yes
	     (forms `(setf (tn-ref-next-ref ,prev) ,n-tail)))
	    (:maybe
	     (forms `(if ,prev
			 (setf (tn-ref-next-ref ,prev) ,n-tail)
			 (setf (vop-refs ,n-vop) ,n-tail)))))
	  
	  (unless (eq first-seen :yes)
	    (setq first-seen (if more-p :maybe :yes)))
	  
	  (if more-p
	      (let ((n-current (gensym))
		    (n-prev (gensym))
		    (n-head (gensym)))
		(binds `(,n-head (or ,var ,prev)))
		(binds
		 `(,n-tail
		   (do ((,n-current ,var (tn-ref-across ,n-current))
			(,n-prev nil ,n-current))
		       ((null ,n-current) ,n-prev)
		     (setf (tn-ref-next-ref ,n-current) ,n-prev))))
		(setq prev n-head))
	      (setq prev var)))))
    
    `((let* ,(binds)
	,@(forms)))))


;;; Make-Temporary  --  Internal
;;;
;;;    Return a form that creates a TN as specified by Temp.  This requires
ram's avatar
ram committed
823
;;; deciding whether the temp is wired or restricted.
wlott's avatar
wlott committed
824
825
826
;;;
(defun make-temporary (temp)
  (declare (type operand-parse temp))
ram's avatar
ram committed
827
828
829
830
831
832
  (let ((sc (operand-parse-sc temp))
	(offset (operand-parse-offset temp)))
    (assert sc)
    (if offset
	`(make-wired-tn ,(sc-number-or-lose sc) ,offset)
	`(make-restricted-tn ,(sc-number-or-lose sc)))))
wlott's avatar
wlott committed
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960

  
;;; Allocate-Temporaries  --  Internal
;;;
;;;    Allocate VOP temporary TNs, making TN-Refs for their start and end, and
;;; setting up various per-ref information.  N-Vop is the temporary holding the
;;; VOP we are emitting.  We return a list of let* binding forms that create
;;; the TN-Refs, a list of forms that initialize the TN-Refs.
;;;
(defun allocate-temporaries (parse n-vop)
  (declare (type vop-parse parse))
  (collect ((binds)
	    (forms))
    (let ((prev-write nil))
      (dolist (temp (vop-parse-temps parse))
	(let ((n-write (operand-parse-temp temp))
	      (n-read (operand-parse-temp-temp temp))
	      (n-tn (gensym)))
	  (binds `(,n-tn ,(make-temporary temp)))
	  (binds `(,n-write (reference-tn ,n-tn t)))
	  (binds `(,n-read (reference-tn ,n-tn nil)))
	  (if prev-write
	      (forms `(setf (tn-ref-across ,prev-write) ,n-write))
	      (forms `(setf (vop-temps ,n-vop) ,n-write)))
	  (setq prev-write n-write)
	  (forms `(setf (tn-ref-vop ,n-read) ,n-vop))
	  (forms `(setf (tn-ref-vop ,n-write) ,n-vop)))))

    (values (binds) (forms))))


;;; Set-VOP-Pointers  --  Internal
;;;
;;;    Return code to set the TN-Ref-Vop slots in some operands to the value of
;;; N-Vop.  If there is no more operand, set the set the slots individually,
;;; otherwise loop over the whole list N-Refs.
;;;
(defun set-vop-pointers (operands more-operand n-vop n-refs)
  (if more-operand
      `((do ((,n-refs ,n-refs (tn-ref-across ,n-refs)))
	    ((null ,n-refs))
	  (setf (tn-ref-vop ,n-refs) ,n-vop)))
      (mapcar #'(lambda (op)
		  `(setf (tn-ref-vop ,(operand-parse-temp op)) ,n-vop))
	      operands)))


;;; Make-Emit-Function  --  Internal
;;;
;;;    Make the Template Emit-Function for a VOP.
;;;
(defun make-emit-function (parse)
  (declare (type vop-parse parse))
  (let ((n-node (gensym)) (n-block (gensym))
	(n-template (gensym)) (n-args (gensym))
	(n-results (gensym)) (n-info (gensym))
	(n-vop (gensym))
	(info-args (vop-parse-info-args parse)))
    (multiple-value-bind (temp-binds temp-forms)
			 (allocate-temporaries parse n-vop)
      `#'(lambda (,n-node ,n-block ,n-template ,n-args ,n-results
			  ,@(when info-args `(,n-info)))
	   (let ((,n-vop (make-vop ,n-block ,n-node ,n-template
				   ,n-args ,n-results)))

	     ,@(when info-args
		 `((setf (vop-codegen-info ,n-vop) ,n-info)))
	     
	     (let* (,@(access-operands (vop-parse-args parse)
				       (vop-parse-more-args parse)
				       n-args)
		    ,@(access-operands (vop-parse-results parse)
				       (vop-parse-more-results parse)
				       n-results)
		    ,@temp-binds)
	       ,@temp-forms
	       ,@(set-vop-pointers (vop-parse-args parse)
				   (vop-parse-more-args parse)
				   n-vop n-args)
	       ,@(set-vop-pointers (vop-parse-results parse)
				   (vop-parse-more-results parse)
				   n-vop n-results)
	       ,@(make-next-ref-linkage parse n-vop))
	     (values ,n-vop ,n-vop))))))


;;; Make-Target-Function  --  Internal
;;;
;;;    Make lambda that does operand targeting as indicated by the
;;; Operand-Parse-Target slots.  We do some meta-compile-time consistency
;;; checking, and the emit a call to Target-If-Desirable for each operand
;;; with a target specified.
;;;
;;;    If we are targeting from a temporary, then we indirect through the TN to
;;; find the read ref.  This exploits the fact that a temp has exactly one
;;; read.
;;;
(defun make-target-function (parse)
  (collect ((forms))
    (dolist (op (vop-parse-operands parse))
      (when (operand-parse-target op)
	(unless (member (operand-parse-kind op) '(:argument :temporary))
	  (error "Cannot target a ~S operand: ~S." (operand-parse-kind op)
		 (operand-parse-name op)))
	(let ((target (find-operand (operand-parse-target op) parse
				    '(:temporary :result))))
	  (forms `(target-if-desirable
		   ,(ecase (operand-parse-kind op)
		      (:temporary
		       `(tn-reads (tn-ref-tn ,(operand-parse-temp op))))
		      (:argument
		       (operand-parse-temp op)))
		   ,(operand-parse-temp target))))))

    (let ((n-vop (gensym)))
      `#'(lambda (,n-vop)
	   (let* (,@(access-operands (vop-parse-args parse) nil
				     `(vop-args ,n-vop))
		  ,@(access-operands (vop-parse-results parse) nil
				     `(vop-results ,n-vop))
		  ,@(access-operands (vop-parse-temps parse) nil
				     `(vop-temps ,n-vop)))
	     ,(ignore-unreferenced-temps (vop-parse-args parse))
	     ,(ignore-unreferenced-temps (vop-parse-results parse))
	     ,(ignore-unreferenced-temps (vop-parse-temps parse))
	     ,@(forms))))))


ram's avatar
ram committed
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;;; Generator functions:

;;; FIND-LOAD-FUNCTIONS  --  Internal
;;;
;;;    Return an alist that translates from lists of SCs we can load OP from to
;;; the load function used for loading those SCs.  We quietly ignore
;;; restrictions to :non-packed (constant) SCs, since we don't load into those
;;; SCs.
;;;
(defun find-load-functions (op load-p)
  (collect ((funs))
    (dolist (sc-name (operand-parse-scs op))
      (let* ((sc (sc-or-lose sc-name))
	     (scn (sc-number sc))
	     (load-scs (append (when load-p
				 (sc-constant-scs sc))
			       (sc-alternate-scs sc))))
	(cond
	 (load-scs
	  (dolist (alt load-scs)
	    (let* ((altn (sc-number alt))
		   (name (if load-p
			     (svref (sc-load-functions sc) altn)
			     (svref (sc-load-functions alt) scn)))
		   (found (or (assoc alt (funs) :test #'member)
			      (rassoc name (funs)))))
	      (unless name
		(error "No load function defined to ~:[save~;load~] SC ~S~
		        ~:[to~;from~] from SC ~S."
		       load-p sc-name load-p (sc-name alt)))
	      
	      (cond (found
		     (unless (eq (cdr found) name)
		       (error "Can't tell whether to ~:[save~;load~] with ~S~@
		               or ~S when operand is in SC ~S."
			      load-p name (cdr found) (sc-name alt)))
		     (pushnew alt (car found)))
		    (t
		     (funs (cons (list alt) name)))))))
	 ((eq (sb-kind (sc-sb sc)) :non-packed))
For faster browsing, not all history is shown. View entire blame