jmp does now works by removing the compression
[aschm:aschm.git] / module / native / assembler / assem.scm
1 (define-module (native assembler assem)
2   #:use-module  (native assembler disassem)
3   #:use-module  (native assembler sbcl)
4   #:use-module  (native assembler sset)
5   #:use-module  (native assembler early-assem)
6   #:use-module  (native assembler params)
7   #:use-module  (rnrs records syntactic)
8   #:use-module  (rnrs bytevectors)
9   #:use-module  (ice-9 pretty-print)
10   #:use-module  (srfi srfi-11)
11   #:use-module  (srfi srfi-1)
12   #:use-module  (system syntax)
13
14   #:export (define-bitfield-emitter define-instruction make-segment inst
15              finalize-segment
16              assemble make-segment
17              segment-buffer
18              emit-back-patch
19              label label? label-position gen-label
20              *assem-scheduler?* *threading*
21              emit-byte emit-back-patch emit-chooser
22              emit-alignment emit-label))
23 ;;;; scheduling assembler
24
25 ;;;; This software is part of the SBCL system. See the README file for
26 ;;;; more information.
27 ;;;;
28 ;;;; This software is derived from the CMU CL system, which was
29 ;;;; written at Carnegie Mellon University and released into the
30 ;;;; public domain. The software is in the public domain and is
31 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
32 ;;;; files for more information.
33
34 ;;;; assembly control parameters
35 (define *threading*           #f)
36 (define *assem-scheduler?*    #f)
37 (define *assem-instructions*  (make-hash-table))
38 (define *assem-max-locations* 0)
39 (define *dyncount*           #f)
40 ;;;; the SEGMENT structure
41
42 ;;; This structure holds the state of the assembler.
43 (define-record-type segment
44   (protocol
45    (mk-cl-protocol
46     (type             #:regular)
47     (buffer           (make-bytevector 1))
48     (run-scheduler    #f)
49     (inst-hook        #f)
50     (current-posn     0)
51     (%current-index   0)
52     (annotations     '())
53     (last-annotation '())
54     (alignment        max-alignment)
55     (sync-posn        0)
56     (final-posn       0)
57     (final-index      0)
58     (postits         '())
59     (inst-number      0)
60     (readers          (make-vector *assem-max-locations* #f))
61     (writers          (make-vector *assem-max-locations* #f))
62     (branch-countdown #f)
63     (emittable-insts-sset (make-sset))
64     (queued-branches '())
65     (delayed         '())
66     (emittable-insts-queue '())
67     (collect-dynamic-statistics #f)))
68
69   (fields
70    ;; the type of this segment (for debugging output and stuff)
71    (mutable type)
72
73    ;; Ordinarily this is a vector where instructions are written. If
74    ;; the segment is made invalid (e.g. by APPEND-SEGMENT) then the
75    ;; vector can be replaced by NIL. This used to be an adjustable
76    ;; array, but we now do the array size management manually for
77    ;; performance reasons (as of 2006-05-13 hairy array operations
78    ;; are rather slow compared to simple ones).
79    (mutable buffer)
80    
81    ;; whether or not to run the scheduler. Note: if the instruction
82    ;; definitions were not compiled with the scheduler turned on, this
83    ;; has no effect.
84    (mutable run-scheduler)
85
86    ;; If a function, then this is funcalled for each inst emitted with
87    ;; the segment, the VOP, the name of the inst (as a string), and the
88    ;; inst arguments.
89    (mutable inst-hook)
90
91    ;; what position does this correspond to? Initially, positions and
92    ;; indexes are the same, but after we start collapsing choosers,
93    ;; positions can change while indexes stay the same.
94    (mutable current-posn)
95    (mutable %current-index)
96
97    ;; a list of all the annotations that have been output to this segment
98    (mutable annotations )
99
100    ;; a pointer to the last cons cell in the annotations list. This is
101    ;; so we can quickly add things to the end of the annotations list.
102    (mutable last-annotation)
103    ;; the number of bits of alignment at the last time we synchronized
104
105    (mutable alignment)
106
107    ;; the position the last time we synchronized
108    (mutable sync-posn)
109
110   ;; The posn and index everything ends at. This is not maintained
111   ;; while the data is being generated, but is filled in after.
112    ;; Basically, we copy CURRENT-POSN and CURRENT-INDEX so that we can
113    ;; trash them while processing choosers and back-patches.
114    (mutable final-posn )
115    (mutable final-index)
116
117    ;; *** State used by the scheduler during instruction queueing.
118    ;;
119    ;; a list of postits. These are accumulated between instructions.
120    (mutable postits)
121
122    ;; ``Number'' for last instruction queued. Used only to supply insts
123    ;; with unique sset-element-number's.
124    (mutable inst-number)
125
126    ;; SIMPLE-VECTORs mapping locations to the instruction that reads them and
127    ;; instructions that write them
128    (mutable readers)
129    (mutable writers )
130    
131    ;; The number of additional cycles before the next control transfer,
132    ;; or NIL if a control transfer hasn't been queued. When a delayed
133    ;; branch is queued, this slot is set to the delay count.
134    (mutable branch-countdown)
135    
136    ;; *** These two slots are used both by the queuing noise and the
137    ;; scheduling noise.
138    ;;
139    ;; All the instructions that are pending and don't have any
140    ;; unresolved dependents. We don't list branches here even if they
141    ;; would otherwise qualify. They are listed above.
142    (mutable emittable-insts-sset)
143    
144    ;; list of queued branches. We handle these specially, because they
145    ;; have to be emitted at a specific place (e.g. one slot before the
146    ;; end of the block).
147    (mutable queued-branches )
148
149    ;; *** state used by the scheduler during instruction scheduling
150    ;;
151    ;; the instructions who would have had a read dependent removed if
152    ;; it were not for a delay slot. This is a list of lists. Each
153    ;; element in the top level list corresponds to yet another cycle of
154    ;; delay. Each element in the second level lists is a dotted pair,
155    ;; holding the dependency instruction and the dependent to remove.
156    (mutable delayed )
157
158    ;; The emittable insts again, except this time as a list sorted by depth.
159    (mutable emittable-insts-queue )
160
161   ;; Whether or not to collect dynamic statistics. This is just the same as
162   ;; *COLLECT-DYNAMIC-STATISTICS* but is faster to reference.))
163    (mutable collect-dynamic-statistics)))
164
165 (defprinter (segment) type)
166   
167 (define (segment-current-index segment)
168   (segment-%current-index segment))
169
170 (define (segment-current-index-set! segment new-value)
171   ;; FIXME: It would be lovely to enforce this, but first FILL-IN will
172   ;; need to be convinced to stop rolling SEGMENT-CURRENT-INDEX
173   ;; backwards.
174   ;;
175   ;; Enforce an observed regularity which makes it easier to think
176   ;; about what's going on in the (legacy) code: The segment never
177   ;; shrinks. -- WHN the reverse engineer
178   (define-syntax-rule (replace new old seg)
179     (begin
180       (segment-buffer-set! segment new)
181       (let ((n (bytevector-length old)))
182         (bytevector-copy! old 0 new 0 n))))
183                 
184   (let* ((buffer (segment-buffer segment))
185          (new-buffer-size (bytevector-length buffer)))
186     ;; Make sure the array is big enough.
187     (when (<= new-buffer-size new-value)
188           (while (> new-buffer-size new-value))
189           ;; When we have to increase the size of the array, we want to
190           ;; roughly double the vector length: that way growing the array
191           ;; to size N conses only O(N) bytes in total. But just doubling
192           ;; the length would leave a zero-length vector unchanged. Hence,
193           ;; take the MAX with 1..
194           (set! new-buffer-size (max 1 (* 2 new-buffer-size)))
195
196           (let ((new-buffer (make-bytevector new-buffer-size)))
197             (replace new-buffer buffer segment)))
198
199     ;; Now that the array has the intended next free byte, we can point to it.
200     (segment-%current-index-set! segment new-value)))
201
202 ;;; Various functions (like BACK-PATCH-FUN or CHOOSER-WORST-CASE-FUN)
203 ;;; aren't cleanly parameterized, but instead use
204 ;;; SEGMENT-CURRENT-INDEX and/or SEGMENT-CURRENT-POSN as global
205 ;;; variables. So code which calls such functions needs to modify
206 ;;; SEGMENT-CURRENT-INDEX and SEGMENT-CURRENT-POSN. This is left over
207 ;;; from the old new-assem.lisp C-style code, and so all the
208 ;;; destruction happens to be done after other uses of these slots are
209 ;;; done and things basically work. However, (1) it's fundamentally
210 ;;; nasty, and (2) at least one thing doesn't work right: OpenMCL
211 ;;; properly points out that SUBSEQ's indices aren't supposed to
212 ;;; exceed its logical LENGTH, i.e. its FILL-POINTER, i.e.
213 ;;; SEGMENT-CURRENT-INDEX.
214 ;;;
215 ;;; As a quick fix involving minimal modification of legacy code,
216 ;;; we do such sets of SEGMENT-CURRENT-INDEX and SEGMENT-CURRENT-POSN
217 ;;; using this macro, which restores 'em afterwards.
218 ;;;
219 ;;; FIXME: It'd probably be better to cleanly parameterize things like
220 ;;; BACK-PATCH-FUN so we can avoid this nastiness altogether.
221 (define-syntax-rule (with-modified-segment-index-and-posn
222                      (segment index posn) . body)
223
224   (let* ((n-segment segment)
225          (old-index (segment-current-index n-segment))
226          (old-posn (segment-current-posn n-segment)))
227     (dynamic-wind
228         (lambda x #f)
229         (lambda ()
230           (segment-current-index-set! n-segment index)
231           (segment-current-posn-set!  n-segment posn)
232           . body)
233         (lambda x
234           (segment-current-index-set! n-segment old-index)
235           (segment-current-posn-set!  n-segment old-posn)))))
236
237 ;;;; structures/types used by the scheduler
238 (!def-boolean-attribute instruction
239   ;; This attribute is set if the scheduler can freely flush this
240   ;; instruction if it thinks it is not needed. Examples are NOP and
241   ;; instructions that have no side effect not described by the
242   ;; writes.
243   flushable
244   ;; This attribute is set when an instruction can cause a control
245   ;; transfer. For test instructions, the delay is used to determine
246   ;; how many instructions follow the branch.
247   branch
248   ;; This attribute indicates that this ``instruction'' can be
249   ;; variable length, and therefore had better never be used in a
250   ;; branch delay slot.
251   variable-length)
252
253 (define-record-type (inst make-instruction instruction?)
254   (parent sset-element)
255
256   (protocol
257    (lambda (n)
258      (lambda (number emitter attributes delay)
259        (let ((p (n number)))
260          (p emitter attributes delay #f 
261             (make-sset) (make-sset) (make-sset) (make-sset))))))
262             
263   (fields
264    ;; The function to envoke to actually emit this instruction. Gets called
265    ;; with the segment as its one argument.
266   (mutable emitter)
267
268   ;; The attributes of this instruction.
269   (mutable attributes)
270
271   ;; Number of instructions or cycles of delay before additional
272   ;; instructions can read our writes.
273   (mutable delay)
274
275   ;; the maximum number of instructions in the longest dependency
276   ;; chain from this instruction to one of the independent
277   ;; instructions. This is used as a heuristic at to which
278   ;; instructions should be scheduled first.
279   (mutable depth)
280
281   ;; Note: When trying remember which of the next four is which, note
282   ;; that the ``read'' or ``write'' always refers to the dependent
283   ;; (second) instruction.
284   ;;
285   ;; instructions whose writes this instruction tries to read
286   (mutable read-dependencies)
287
288   ;; instructions whose writes or reads are overwritten by this instruction
289   (mutable write-dependencies)
290
291   ;; instructions which write what we read or write
292   (mutable write-dependents)
293
294   ;; instructions which read what we write
295   (mutable read-dependents)))
296
297 (define instruction inst)
298   
299
300 (add-printer instruction
301   (lambda (inst stream)    
302     (format stream
303             "emitter=~S"
304             (let ((emitter (inst-emitter inst)))
305               (if emitter
306                   (procedure-name emitter)
307                   '<flushed>)))
308     (when (inst-depth inst)
309           (format stream ", depth=~W" (inst-depth inst)))))
310
311
312 ;;;; the scheduler itself
313
314 (define-syntax without-scheduling   
315   (syntax-rules ()
316     ((_ ()        . body)
317      (without-scheduling (%%current-segment%%)  . body))
318     ((_ (segment) body ...)
319 ;;     "Execute BODY (as a PROGN) without scheduling any of the instructions
320 ;;   generated inside it. This is not protected by UNWIND-PROTECT, so
321 ;;   DO NOT use THROW or RETURN-FROM to escape from it."
322   
323 ;; FIXME: Why not just use UNWIND-PROTECT? Or is there some other
324 ;; reason why we shouldn't use THROW or RETURN-FROM?
325      (let* ((seg segment)
326             (var (segment-run-scheduler seg)))
327        (when var
328          (schedule-pending-instructions seg)
329          (setf (segment-run-scheduler seg) #f))
330        body ...
331        (setf (segment-run-scheduler seg) var)))))
332
333 ;;TODO, define the syntax parameters!
334 (define-syntax-rule (note-dependencies (segment inst) body ...)
335   (let ((-segment segment) (-inst inst))
336     (syntax-parameterize
337      ((reads 
338        (syntax-rules () 
339          ((_ loc)
340           (note-read-dependency) -segment -inst loc)))
341
342       (writes
343        (syntax-rules () 
344          ((_ loc . keys)
345           (note-write-dependency -segment -inst loc . keys)))))
346      body ...)))
347
348
349
350 (define (note-read-dependency segment inst read)
351   (let-values (((loc-num size) (location-number read)))
352     (when loc-num
353       ;; Iterate over all the locations for this TN.
354       (do ((index loc-num (+ 1 index))
355            (end-loc (+ loc-num (or size 1))))
356           ((>= index end-loc))
357         (let ((writers (vector-ref (segment-writers segment) index)))
358           (when writers
359             ;; The inst that wrote the value we want to read must have
360             ;; completed.
361             (let ((writer (car writers)))
362               (sset-adjoin writer (inst-read-dependencies inst))
363               (sset-adjoin inst (inst-read-dependents writer))
364               (sset-delete writer (segment-emittable-insts-sset segment))
365               ;; And it must have been completed *after* all other
366               ;; writes to that location. Actually, that isn't quite
367               ;; true. Each of the earlier writes could be done
368               ;; either before this last write, or after the read, but
369               ;; we have no way of representing that.
370               (dolist (other-writer (cdr writers))
371                 (sset-adjoin other-writer (inst-write-dependencies writer))
372                 (sset-adjoin writer (inst-write-dependents other-writer))
373                 (sset-delete other-writer
374                              (segment-emittable-insts-sset segment))))
375             ;; And we don't need to remember about earlier writes any
376             ;; more. Shortening the writers list means that we won't
377             ;; bother generating as many explicit arcs in the graph.
378             (set-cdr! writers '())))
379         (set! inst (cons (vector-ref (segment-readers segment) index) inst)))))
380   (values))
381
382
383
384 (define* (note-write-dependency segment inst write #:key (partially #f))
385   (let-values  (((loc-num size)
386                  (location-number write)))
387     (when loc-num
388       ;; Iterate over all the locations for this TN.
389       (do ((index loc-num (1+ index))
390            (end-loc (+ loc-num (or size 1))))
391           ((>= index end-loc))
392         ;; All previous reads of this location must have completed.
393         (dolist (prev-inst (vector-ref (segment-readers segment) index))
394           (unless (eq? prev-inst inst)
395             (sset-adjoin prev-inst (inst-write-dependencies inst))
396             (sset-adjoin inst (inst-write-dependents prev-inst))
397             (sset-delete prev-inst (segment-emittable-insts-sset segment))))
398         (when partially
399           ;; All previous writes to the location must have completed.
400           (dolist (prev-inst (vector-ref (segment-writers segment) index))
401             (sset-adjoin prev-inst (inst-write-dependencies inst))
402             (sset-adjoin inst (inst-write-dependents prev-inst))
403             (sset-delete prev-inst (segment-emittable-insts-sset segment)))
404           ;; And we can forget about remembering them, because
405           ;; depending on us is as good as depending on them.
406           (vector-set! (segment-writers segment) index #f))
407         (set! inst (cons (vector-ref (segment-writers segment) index)
408                          inst)))))
409   (values))
410
411 ;;; This routine is called by due to uses of the INST macro when the
412 ;;; scheduler is turned on. The change to the dependency graph has
413 ;;; already been computed, so we just have to check to see whether the
414 ;;; basic block is terminated.
415 (define (queue-inst segment inst)
416   (aver (segment-run-scheduler segment))
417   (let ((countdown (segment-branch-countdown segment)))
418     (when (> countdown 0)
419           (set! countdown (- countdown 1))
420           (aver (not (instruction-attribute? (inst-attributes inst)
421                                              variable-length))))
422     (cond ((instruction-attribute? (inst-attributes inst) branch)
423            (unless (> countdown 0)
424                    (set! countdown (inst-delay inst)))
425            (segment-queued-branches-set! 
426             segment
427             (cons (cons countdown inst)
428                   (segment-queued-branches segment))))
429
430           (else
431            (sset-adjoin inst (segment-emittable-insts-sset segment))))
432
433     (when (> countdown 0)
434           (segment-branch-countdown-set! segment countdown)
435           (when (= 0 countdown)
436                 (schedule-pending-instructions segment)))
437
438     (values)))
439
440
441 ;;; a utility for maintaining the segment-delayed list. We cdr down
442 ;;; list n times (extending it if necessary) and then push thing on
443 ;;; into the car of that cons cell.
444 (define (add-to-nth-list li thing n)
445   (let ((l (if (pair? li) li (list '()))))
446     (let loop ((l l) (i n))
447       (if (= i 0)
448           (set-car! li (cons thing (car li)))
449           (aif (it) (cdr li)
450                (loop it (- i 1))
451                (let ((it (cons '() '())))
452                  (set-cdr! l it)
453                  (loop it (- i 1))))))
454     l))
455
456 ;;; Emit all the pending instructions, and reset any state. This is
457 ;;; called whenever we hit a label (i.e. an entry point of some kind)
458 ;;; and when the user turns the scheduler off (otherwise, the queued
459 ;;; instructions would sit there until the scheduler was turned back
460 ;;; on, and emitted in the wrong place).
461 (define (schedule-pending-instructions segment)
462   (aver (segment-run-scheduler segment))
463
464   ;; Quick blow-out if nothing to do.
465   (cond 
466    ((and (sset-empty? (segment-emittable-insts-sset segment))
467          (null? (segment-queued-branches segment)))
468     (values))
469
470   ;; Note that any values live at the end of the block have to be
471   ;; computed last.
472    (else
473     (let ((emittable-insts (segment-emittable-insts-sset segment))
474           (writers         (segment-writers segment)))
475      (dotimes (index (length writers))
476         (let* ((writer      (vector-ref writers index))
477                (inst        (car writer))
478                (overwritten (cdr writer)))
479            (when writer
480               (when overwritten
481                     (let ((write-dependencies (inst-write-dependencies inst)))
482                     (dolist (other-inst overwritten)
483                 (sset-adjoin inst (inst-write-dependents other-inst))
484                 (sset-adjoin other-inst write-dependencies)
485                 (sset-delete other-inst emittable-insts))))
486               ;; If the value is live at the end of the block, 
487               ;; we can't flush it.
488               (attribute-set!
489                (instruction-attribute? (inst-attributes inst) flushable)
490                #f)))))
491
492            ;; Grovel through the entire graph in the forward direction finding
493   ;; all the leaf instructions.
494   
495   (letrec ((grovel-inst 
496             (lambda (inst)
497               (let ((max 0))
498                 (do-sset-elements (dep (inst-write-dependencies inst))
499                    (let ((dep-depth (or (inst-depth dep) (grovel-inst dep))))
500                      (when (> dep-depth max)
501                            (set! max dep-depth))))
502                 (do-sset-elements (dep (inst-read-dependencies inst))
503                    (let ((dep-depth
504                           (+ (or (inst-depth dep) (grovel-inst dep))
505                              (inst-delay dep))))
506                      (when (> dep-depth max)
507                        (set! max dep-depth))))
508
509                 (cond ((and (sset-empty? (inst-read-dependents inst))
510                             (instruction-attribute? (inst-attributes inst)
511                                                     flushable))
512                        (inst-emitter-set! inst #f)
513                        (inst-depth-set!   inst max)
514                        max)
515                      (else
516                       (inst-depth-set! inst max)
517                       max))))))
518     (let ((emittable-insts '())
519           (delayed         '()))
520       (do-sset-elements (inst (segment-emittable-insts-sset segment))
521         (grovel-inst inst)
522         (if (zero? (inst-delay inst))
523             (set! emittable-insts (cons inst emittable-insts))
524             (set! delayed
525                   (add-to-nth-list delayed inst (1- (inst-delay inst))))))
526       (segment-emittable-insts-queue-set! 
527        segment
528        (sort emittable-insts (lambda (x y) (> (inst-depth x) (inst-depth y)))))
529       (segment-delayed-set! segment delayed))
530
531     (dolist (branch (segment-queued-branches segment))
532             (grovel-inst (cdr branch))))
533
534   ;; Accumulate the results in reverse order. Well, actually, this
535   ;; list will be in forward order, because we are generating the
536   ;; reverse order in reverse.
537   (let ((results '()))
538     ;; Schedule all the branches in their exact locations.
539     (let ((insts-from-end (segment-branch-countdown segment)))
540       (dolist (branch (segment-queued-branches segment))
541         (let ((inst (cdr branch)))
542           (dotimes (i (- (car branch) insts-from-end))
543             ;; Each time through this loop we need to emit another
544             ;; instruction. First, we check to see whether there is
545             ;; any instruction that must be emitted before (i.e. must
546             ;; come after) the branch inst. If so, emit it. Otherwise,
547             ;; just pick one of the emittable insts. If there is
548             ;; nothing to do, then emit a nop. ### Note: despite the
549             ;; fact that this is a loop, it really won't work for
550             ;; repetitions other then zero and one. For example, if
551             ;; the branch has two dependents and one of them dpends on
552             ;; the other, then the stuff that grabs a dependent could
553             ;; easily grab the wrong one. But I don't feel like fixing
554             ;; this because it doesn't matter for any of the
555             ;; architectures we are using or plan on using.
556          (letrec ((maybe-schedule-dependent 
557                    (lambda (dependents)
558                      (do-sset-elements (inst dependents)
559                        ;; If do-sset-elements enters the body, then there is a
560                        ;; dependent. Emit it.
561                        (note-resolved-dependencies segment inst)
562                        ;; Remove it from the emittable insts.
563                        (segment-emittable-insts-queue-set!
564                         segment
565                         (remove (lambda (x) (eq? inst x))
566                                 (segment-emittable-insts-queue segment)))
567                                 
568                        ;; And if it was delayed, removed it from the delayed
569                        ;; list. This can happen if there is a load in a
570                        ;; branch delay slot.
571                        (let loop ((delayed (segment-delayed segment)))
572                          (if (pair? delayed)
573                              (let loop2 ((prev '()) (c (car delayed)))
574                                (if (pair? c)
575                                    (begin
576                                      (when (eq? (car c) inst)
577                                            (if (pair? prev)
578                                                (set-cdr! prev    (cdr c))
579                                                (set-car! delayed (cdr c)))
580                                            (loop '()))
581                                      (loop2 c (cdr c)))
582                                    (loop (cdr delayed))))
583                              #f))
584                        ;; And return it.
585                        inst))))
586
587            (let ((fill (or (maybe-schedule-dependent
588                             (inst-read-dependents inst))
589                            (maybe-schedule-dependent
590                             (inst-write-dependents inst))
591                            (schedule-one-inst segment #t)
592                            #:nop)))
593              
594              (set! results (cons fill results))
595              (advance-one-inst segment)
596              (set! insts-from-end (+ insts-from-end 1))
597              (note-resolved-dependencies segment inst)
598              (set! results (cons inst results))
599              (advance-one-inst segment)))))))
600
601     ;; Keep scheduling stuff until we run out.
602     (awhile (inst (schedule-one-inst segment #f))
603        (set! results (cons inst results))
604        (advance-one-inst segment))
605
606     ;; Now call the emitters, but turn the scheduler off for the duration.
607     (segment-run-scheduler-set! segment #f)
608     (dolist (inst results)
609       (if (eq? inst #:nop)
610           (emit-nop segment)
611           ((inst-emitter inst) segment)))
612     (segment-run-scheduler-set! segment #t))
613
614   ;; Clear out any residue left over.
615   (segment-inst-number-set!          segment   0)
616   (segment-queued-branches-set!      segment  '())
617   (segment-branch-countdown-set!     segment  '())
618   (segment-emittable-insts-sset-set! segment  (make-sset))
619   (fill (segment-readers segment) #f)
620   (fill (segment-writers segment) #f)
621
622   ;; That's all, folks.
623   (values))))
624
625
626
627 ;;; Find the next instruction to schedule and return it after updating
628 ;;; any dependency information. If we can't do anything useful right
629 ;;; now, but there is more work to be done, return :NOP to indicate
630 ;;; that a nop must be emitted. If we are all done, return NIL.
631 (define (schedule-one-inst segment delay-slot?)
632   (let loop ((prev      '())  
633              (remaining (segment-emittable-insts-queue segment)))
634
635       (if (pair? remaining)
636         (let ((inst (car remaining)))
637           (unless (and delay-slot?
638                        (instruction-attribute? (inst-attributes inst)
639                                                variable-length))
640             ;; We've got us a live one here. Go for it.
641
642             ;; Delete it from the list of insts.
643             (if (pair? prev)
644                 (set-cdr! prev (cdr remaining))
645                 (segment-emittable-insts-queue-set! 
646                    segment
647                   (cdr remaining)))
648
649             ;; Note that this inst has been emitted.
650             (note-resolved-dependencies segment inst)
651
652             ;; And return.
653             (if (inst-emitter inst)
654                 ;; Nope, it's still a go. So return it.
655                 inst
656                 ;; Yes, so pick a new one. We have to start
657                 ;; over, because note-resolved-dependencies
658                 ;; might have changed the emittable-insts-queue.
659                 (schedule-one-inst segment delay-slot?))))
660
661         ;; Nothing to do, so make something up.
662         (cond ((segment-delayed segment)
663                ;; No emittable instructions, but we have more work to do. Emit
664                ;; a NOP to fill in a delay slot.
665                #:nop)
666               (else
667                ;; All done.
668                #f)))))
669
670
671
672 ;;; This function is called whenever an instruction has been
673 ;;; scheduled, and we want to know what possibilities that opens up.
674 ;;; So look at all the instructions that this one depends on, and
675 ;;; remove this instruction from their dependents list. If we were the
676 ;;; last dependent, then that dependency can be emitted now.
677 (define (note-resolved-dependencies segment inst)
678   (aver (sset-empty? (inst-read-dependents inst)))
679   (aver (sset-empty? (inst-write-dependents inst)))
680
681   (do-sset-elements (dep (inst-write-dependencies inst))
682     ;; These are the instructions who have to be completed before our
683     ;; write fires. Doesn't matter how far before, just before.
684     (let ((dependents (inst-write-dependents dep)))
685       (sset-delete inst dependents)
686       (when (and (sset-empty? dependents)
687                  (sset-empty? (inst-read-dependents dep)))
688         (insert-emittable-inst segment dep))))
689
690   (do-sset-elements (dep (inst-read-dependencies inst))
691     ;; These are the instructions who write values we read. If there
692     ;; is no delay, then just remove us from the dependent list.
693     ;; Otherwise, record the fact that in n cycles, we should be
694     ;; removed.
695     (if (zero? (inst-delay dep))
696         (let ((dependents (inst-read-dependents dep)))
697           (sset-delete inst dependents)
698           (when (and (sset-empty? dependents)
699                      (sset-empty? (inst-write-dependents dep)))
700             (insert-emittable-inst segment dep)))
701         (segment-delayed-set! segment
702               (add-to-nth-list (segment-delayed segment)
703                                (cons dep inst)
704                                (inst-delay dep)))))
705   (values))
706
707
708
709 ;;; Process the next entry in segment-delayed. This is called whenever
710 ;;; anyone emits an instruction.
711 (define (advance-one-inst segment)
712   (let ((delayed-stuff (let ((r (segment-delayed segment)))
713                          (if (pair? r)
714                              (begin
715                                (segment-delayed-set! segment (cdr r))
716                                (car r))
717                              '()))))
718
719     (dolist (stuff delayed-stuff)
720       (if (pair? stuff)
721           (let* ((dependency (car stuff))
722                  (dependent  (cdr stuff))
723                  (dependents (inst-read-dependents dependency)))
724             (sset-delete dependent dependents)
725             (when (and (sset-empty? dependents)
726                        (sset-empty? (inst-write-dependents dependency)))
727               (insert-emittable-inst segment dependency)))
728           (insert-emittable-inst segment stuff)))))
729
730
731
732 ;;; Note that inst is emittable by sticking it in the
733 ;;; SEGMENT-EMITTABLE-INSTS-QUEUE list. We keep the emittable-insts
734 ;;; sorted with the largest ``depths'' first. Except that if INST is a
735 ;;; branch, don't bother. It will be handled correctly by the branch
736 ;;; emitting code in SCHEDULE-PENDING-INSTRUCTIONS.
737 (define (insert-emittable-inst segment inst)
738   (unless (instruction-attribute? (inst-attributes inst) branch)
739     (do ((my-depth (inst-depth inst))
740          (remaining (segment-emittable-insts-queue segment) (cdr remaining))
741          (prev '() remaining))
742       ((or (null? remaining) (> my-depth (inst-depth (car remaining))))
743          (if (pair? prev)
744              (set-cdr! prev (cons inst remaining))
745              (segment-emittable-insts-queue-set! 
746               segment
747               (cons inst remaining))))))
748   (values))
749
750 ;;;; structure used during output emission
751
752 ;;; common supertype for all the different kinds of annotations
753 (define-record-type annotation
754   (protocol
755    (lambda (n)
756      (lambda () (n 0 #f))))
757
758   (fields
759    ;; Where in the raw output stream was this annotation emitted?
760    (mutable index)
761    ;; What position does that correspond to?
762    (mutable posn)))
763
764 (define-record-type (label gen-label label?)
765   (parent annotation)
766   (protocol (lambda (n) (lambda () ((n)))))
767   ;; (doesn't need any additional information beyond what is in the
768   ;; annotation structure)
769   )
770
771 (add-printer label
772   (lambda (label stream)
773     (format stream "L~A" (annotation-posn label))))
774
775 ;;; a constraint on how the output stream must be aligned
776
777 (define-record-type alignment
778   (parent annotation)
779   (protocol
780    (lambda (n)
781      (lambda (bit size fill-byte)
782        (let ((p (n)))
783          (p bit size fill-byte)))))
784   (fields
785    (mutable bits)
786    (mutable size)
787    (mutable fill-byte)))
788
789 ;;; a reference to someplace that needs to be back-patched when
790 ;;; we actually know what label positions, etc. are
791 (define-record-type back-patch
792   (parent annotation)
793   (protocol
794    (lambda (n)
795      (lambda (size fun)
796        (let ((p (n)))
797          (p size fun)))))
798   (fields
799    (mutable size)
800    (mutable fun)))
801
802 ;;; This is similar to a BACK-PATCH, but also an indication that the
803 ;;; amount of stuff output depends on label positions, etc.
804 ;;; BACK-PATCHes can't change their mind about how much stuff to emit,
805 ;;; but CHOOSERs can.
806 (define-record-type chooser
807   (parent annotation)
808   (protocol
809    (lambda (n)
810      (lambda (size align shrink worst)
811        (let ((p (n)))
812          (p size align shrink worst)))))
813   (fields
814    ;; the worst case size for this chooser. There is this much space
815    ;; allocated in the output buffer.
816    (mutable size)
817
818    ;; the worst case alignment this chooser is guaranteed to preserve
819    (mutable alignment)
820
821    ;; the function to call to determine if we can use a shorter
822    ;; sequence. It returns NIL if nothing shorter can be used, or emits
823    ;; that sequence and returns #t.
824    (mutable maybe-shrink)
825
826    ;; the function to call to generate the worst case sequence. This is
827    ;; used when nothing else can be condensed.   
828    (mutable worst-case-fun)))
829
830
831 ;;; This is used internally when we figure out a chooser or alignment
832 ;;; doesn't really need as much space as we initially gave it.
833
834 (define-record-type filler
835   (parent annotation)
836   (protocol
837    (lambda (n)
838      (lambda (bytes)
839        (let ((p (n)))
840          (p bytes)))))
841   (fields (mutable bytes)))
842
843 ;;;; output functions
844
845 ;;; interface: Emit the supplied BYTE to SEGMENT, growing SEGMENT if
846 ;;; necessary.
847 (define (emit-byte segment byte)
848   (let ((old-index (segment-current-index segment)))
849     (segment-current-index-set! segment 
850                                 (+ (segment-current-index segment) 1))
851
852     (u8vector-set! (segment-buffer segment) old-index
853                      (logand byte assembly-unit-mask))
854
855     (segment-current-posn-set! segment (+ 1 (segment-current-posn segment)))
856     
857     (values)))
858
859 ;;; interface: Output AMOUNT copies of FILL-BYTE to SEGMENT.
860 (define* (emit-skip segment amount #:optional (fill-byte 0))
861   (dotimes (i amount)
862            (emit-byte segment fill-byte))
863   (values))
864
865 ;;; This is used to handle the common parts of annotation emission. We
866 ;;; just assign the POSN and INDEX of NOTE and tack it on to the end
867 ;;; of SEGMENT's annotations list.
868 (define (emit-annotation segment note)
869   (when (annotation-posn note)
870     (error "attempt to emit ~S a second time" note))
871   (pk note)
872   (pk `(label-pos-ref  ,(annotation-posn note)))
873   (pk `(label-pos-set! ,(segment-current-posn segment)))
874   (annotation-posn-set!  note (segment-current-posn segment))
875   (annotation-index-set! note (segment-current-index segment))
876   (let ((last (segment-last-annotation segment))
877         (new (list note)))
878     (segment-last-annotation-set! 
879      segment
880      (begin
881        (if (pair? last)
882            (set-cdr! last new)
883            (segment-annotations-set! segment new))
884        new)))
885   (values))
886
887 ;;; Note that the instruction stream has to be back-patched when label
888 ;;; positions are finally known. SIZE bytes are reserved in SEGMENT,
889 ;;; and function will be called with two arguments: the segment and
890 ;;; the position. The function should look at the position and the
891 ;;; position of any labels it wants to and emit the correct sequence.
892 ;;; (And it better be the same size as SIZE). SIZE can be zero, which
893 ;;; is useful if you just want to find out where things ended up.
894 (define (emit-back-patch segment size function)
895   (emit-annotation segment (make-back-patch size function))
896   (emit-skip segment size))
897
898 ;;; Note that the instruction stream here depends on the actual
899 ;;; positions of various labels, so can't be output until label
900 ;;; positions are known. Space is made in SEGMENT for at least SIZE
901 ;;; bytes. When all output has been generated, the MAYBE-SHRINK
902 ;;; functions for all choosers are called with three arguments: the
903 ;;; segment, the position, and a magic value. The MAYBE-SHRINK
904 ;;; decides if it can use a shorter sequence, and if so, emits that
905 ;;; sequence to the segment and returns T. If it can't do better than
906 ;;; the worst case, it should return NIL (without emitting anything).
907 ;;; When calling LABEL-POSITION, it should pass it the position and
908 ;;; the magic-value it was passed so that LABEL-POSITION can return
909 ;;; the correct result. If the chooser never decides to use a shorter
910 ;;; sequence, the WORST-CASE-FUN will be called, just like a
911 ;;; BACK-PATCH. (See EMIT-BACK-PATCH.)
912 (define (emit-chooser segment size alignment maybe-shrink worst-case-fun)
913   (let ((chooser (make-chooser size alignment maybe-shrink worst-case-fun)))
914     (emit-annotation segment chooser)
915     (emit-skip segment size)
916     (adjust-alignment-after-chooser segment chooser)))
917
918 ;;; This is called in EMIT-CHOOSER and COMPRESS-SEGMENT in order to
919 ;;; recompute the current alignment information in light of this
920 ;;; chooser. If the alignment guaranteed by the chooser is less than
921 ;;; the segment's current alignment, we have to adjust the segment's
922 ;;; notion of the current alignment.
923 ;;;
924 ;;; The hard part is recomputing the sync posn, because it's not just
925 ;;; the chooser's posn. Consider a chooser that emits either one or
926 ;;; three words. It preserves 8-byte (3 bit) alignments, because the
927 ;;; difference between the two choices is 8 bytes.
928 (define (adjust-alignment-after-chooser segment chooser)
929   (let ((alignment     (chooser-alignment chooser))
930         (seg-alignment (segment-alignment segment)))
931     (when (< alignment seg-alignment)
932       ;; The chooser might change the alignment of the output. So we
933       ;; have to figure out what the worst case alignment could be.
934       (segment-alignment-set! segment alignment)
935       (let* ((posn      (annotation-posn chooser))
936              (sync-posn (segment-sync-posn segment))
937              (offset    (- posn sync-posn))
938              (delta     (logand offset (1- (ash 1 alignment)))))
939         (segment-sync-posn-set! segment (- posn delta)))))
940   #f)
941
942 ;;; This is used internally whenever a chooser or alignment decides it
943 ;;; doesn't need as much space as it originally thought.
944 (define (emit-filler segment n-bytes)
945   (let ((last (segment-last-annotation segment)))
946     (cond ((and (pair? last) (filler? (car last)))
947            (filler-bytes-set! (car last)
948                               (+ (filler-bytes (car last)) n-bytes)))
949           (else
950            (emit-annotation segment (make-filler n-bytes))))
951     (segment-current-index-set! 
952      segment
953      (+ (segment-current-index segment) n-bytes)))
954   (values))
955
956 ;;; EMIT-LABEL (the interface) basically just expands into this,
957 ;;; supplying the SEGMENT and VOP.
958 (define (%emit-label segment vop label)
959   (when (segment-run-scheduler segment)
960         (schedule-pending-instructions segment))
961   (let ((postits (segment-postits segment)))
962     (segment-postits-set! segment '())
963     (dolist (postit postits)
964             (emit-back-patch segment 0 postit)))
965   (let ((hook (segment-inst-hook segment)))
966     (when hook
967           (hook segment vop #:label label)))
968   (emit-annotation segment label))
969
970
971 ;;; Called by the EMIT-ALIGNMENT macro to emit an alignment note. We check to
972 ;;; see if we can guarantee the alignment restriction by just outputting a
973 ;;; fixed number of bytes. If so, we do so. Otherwise, we create and emit an
974 ;;; alignment note.
975 (define* (%emit-alignment segment vop bits #:optional (fill-byte 0))
976   (when (segment-run-scheduler segment)
977         (schedule-pending-instructions segment))
978   (let ((hook (segment-inst-hook segment)))
979     (when hook
980           (hook segment vop #:align bits)))
981   (let ((alignment (segment-alignment segment))
982         (offset (- (segment-current-posn segment)
983                    (segment-sync-posn segment))))
984     (cond ((> bits alignment)
985            ;; We need more bits of alignment. First emit enough noise
986            ;; to get back in sync with alignment, and then emit an
987            ;; alignment note to cover the rest.
988            (let ((slop (logand offset (1- (ash 1 alignment)))))
989              (unless (zero? slop)
990                      (emit-skip segment (- (ash 1 alignment) slop) fill-byte)))
991            (let ((size (logand (1- (ash 1 bits))
992                                (lognot (1- (ash 1 alignment))))))
993              (aver (> size 0))
994              (emit-annotation segment (make-alignment bits size fill-byte))
995              (emit-skip segment size fill-byte))
996            (segment-alignment-set! segment bits)
997            (segment-sync-posn-set! segment (segment-current-posn segment)))
998           (else
999            ;; The last alignment was more restrictive than this one.
1000            ;; So we can just figure out how much noise to emit
1001            ;; assuming the last alignment was met.
1002            (let* ((mask (1- (ash 1 bits)))
1003                   (new-offset (logand (+ offset mask) (lognot mask))))
1004              (emit-skip segment (- new-offset offset) fill-byte))
1005            ;; But we emit an alignment with size=0 so we can verify
1006            ;; that everything works.
1007            (emit-annotation segment (make-alignment bits 0 fill-byte)))))
1008   (values))
1009
1010 ;;; This is used to find how ``aligned'' different offsets are.
1011 ;;; Returns the number of low-order 0 bits, up to MAX-ALIGNMENT.
1012 (define (find-alignment offset)
1013   (let loop ((i 0))
1014     (if (= i max-alignment)
1015         max-alignment
1016         (if (logbit? i offset)
1017             i
1018             (loop (+ i 1))))))
1019
1020 ;;; Emit a postit. The function will be called as a back-patch with
1021 ;;; the position the following instruction is finally emitted. Postits
1022 ;;; do not interfere at all with scheduling.
1023 (define (%emit-postit segment function)
1024   (segment-postits-set! segment 
1025                         (cons function 
1026                               (segment-postits segment)))
1027   (values))
1028
1029 ;;;; output compression/position assignment stuff
1030 ;;; Grovel though all the annotations looking for choosers. When we
1031 ;;; find a chooser, invoke the maybe-shrink function. If it returns T,
1032 ;;; it output some other byte sequence.
1033 (define (compress-output segment)
1034   (let times ((i 5)) ; it better not take more than one or two passes.
1035     (if (> i 0)
1036         (let ((delta 0))
1037           (segment-alignment-set! segment max-alignment)
1038           (segment-sync-posn-set! segment 0)
1039           (let loop ((prev '())
1040                      (remaining (segment-annotations segment))
1041                      (next      (if (pair?  (segment-annotations segment))
1042                                     (cdr (segment-annotations segment))
1043                                     #f)))
1044             (if (pair? remaining) 
1045                 (let* ((note (car remaining))
1046                        (posn (annotation-posn note)))
1047                   (unless (zero? delta)
1048                           (set! posn (- posn delta))
1049                           (annotation-posn-set! note posn))
1050                   
1051                   (cond
1052                    ((chooser? note)
1053                     (with-modified-segment-index-and-posn 
1054                      (segment (annotation-index note)
1055                               posn)
1056                      (segment-last-annotation-set! segment prev)
1057                      (cond
1058                       (((chooser-maybe-shrink note) segment posn delta)
1059                        ;; It emitted some replacement.
1060                        (let ((new-size (- (segment-current-index segment)
1061                                           (annotation-index note)))
1062                              (old-size (chooser-size note)))
1063                          (when (> new-size old-size)
1064                     (merror "~S emitted ~W bytes, but claimed its max was ~W."
1065                             note new-size old-size))
1066                          (let ((additional-delta (- old-size new-size)))
1067                            (when (< (find-alignment additional-delta)
1068                                     (chooser-alignment note))
1069                           (merror "~S shrunk by ~W bytes, but claimed that it ~
1070                               preserves ~W bits of alignment."
1071                                   note additional-delta 
1072                                   (chooser-alignment note)))
1073                            (set! delta (+ delta additional-delta))
1074                            (emit-filler segment additional-delta))
1075                          (set! prev (segment-last-annotation segment))
1076                          (if (pair? prev)
1077                              (set-cdr! prev (cdr remaining))
1078                              (segment-annotations-set! segment
1079                                                        (cdr remaining)))))
1080                       (else
1081                        ;; The chooser passed on shrinking. Make sure it didn't
1082                        ;; emit anything.
1083                        (unless (= (segment-current-index segment)
1084                                   (annotation-index note))
1085             (merror "Chooser ~S passed, but not before emitting ~W bytes."
1086                     note
1087                     (- (segment-current-index segment)
1088                        (annotation-index note))))
1089                        ;; Act like we just emitted this chooser.
1090                        (let ((size (chooser-size note)))
1091                          (segment-current-index-set! 
1092                           segment
1093                           (+ size (segment-current-index segment)))
1094                          (segment-current-posn-set! 
1095                           segment
1096                           (+ size (segment-current-posn segment))))
1097                        ;; Adjust the alignment accordingly.
1098                        (adjust-alignment-after-chooser segment note)
1099                        ;; And keep this chooser for next time around.
1100                        (set! prev remaining)))))
1101                    ((alignment? note)
1102                     (unless (zero? (alignment-size note))
1103                      ;; Re-emit the alignment, letting it collapse if we know
1104                      ;; anything more about the alignment guarantees of the
1105                      ;; segment.
1106                             (let ((index (annotation-index note)))
1107                               (with-modified-segment-index-and-posn 
1108                                (segment index posn)
1109                                (segment-last-annotation-set! segment prev)
1110                                (%emit-alignment segment #f 
1111                                                 (alignment-bits note)
1112                                                 (alignment-fill-byte note))
1113                                (let* ((new-index        
1114                                        (segment-current-index segment))
1115                                       (size    
1116                                        (- new-index index))
1117                                       (old-size         
1118                                        (alignment-size note))
1119                                       (additional-delta 
1120                                        (- old-size size)))
1121                                  (when (< additional-delta 0)
1122                                    (merror "Alignment ~S needs more space now?  It was ~S, and is ~S now."
1123                                            note old-size size))
1124                                  (when (> additional-delta 0)
1125                                        (emit-filler segment additional-delta)
1126                                        (set! delta (+ delta additional-delta))))
1127                                (set! prev (segment-last-annotation segment))
1128                                (if (pair? prev)
1129                                    (set-cdr! prev (cdr remaining))
1130                                    (segment-annotations-set! 
1131                                     segment
1132                                     (cdr remaining)))))))
1133                    (else
1134                     (set! prev remaining)))       
1135                   (loop prev next (cdr remaining)))))
1136       
1137           (when (not (zero? delta))
1138                 (segment-final-posn-set! segment 
1139                                          (- (segment-final-posn segment) delta))
1140                 (times (- i 1))))))
1141   (values))
1142
1143
1144
1145 ;;; We have run all the choosers we can, so now we have to figure out
1146 ;;; exactly how much space each alignment note needs.
1147 (define (finalize-positions segment)
1148   (let ((delta 0))
1149     (let loop ((prev     '())
1150                (remaining (segment-annotations segment))
1151                (next      (if (pair? (segment-annotations segment))
1152                               (cdr (segment-annotations segment))
1153                               #f)))
1154   (if (pair? remaining)
1155       (let* ((note (car remaining))
1156              (posn (- (annotation-posn note) delta)))
1157         (cond
1158          ((alignment? note)
1159           (let* ((bits     (alignment-bits note))
1160                  (mask     (1- (ash 1 bits)))
1161                  (new-posn (logand (+ posn mask) (lognot mask)))
1162                  (size     (- new-posn posn))
1163                  (old-size (alignment-size note))
1164                  (additional-delta (- old-size size)))
1165             (aver (<= 0 size old-size))
1166             (unless (zero? additional-delta)
1167               (segment-last-annotation-set! segment prev)
1168               (set! delta (+ delta additional-delta))
1169               (with-modified-segment-index-and-posn (segment
1170                                                      (annotation-index note)
1171                                                      posn)
1172                 (emit-filler segment additional-delta)
1173                 (set! prev (segment-last-annotation segment))
1174                 (if (pair? prev)
1175                     (set-cdr! prev next)
1176                     (segment-annotations-set! segment next))))))
1177          (else
1178           (annotation-posn-set! note posn)
1179           (set! prev remaining)
1180           (set! next (cdr remaining))))
1181         (unless (zero? delta)
1182                 (segment-final-posn-set!
1183                  segment
1184                  (- (segment-final-posn segment)
1185                     delta)))
1186
1187         (loop prev next (cdr remaining))))))
1188   (values))
1189
1190
1191 ;;; Grovel over segment, filling in any backpatches. If any choosers
1192 ;;; are left over, we need to emit their worst case variant.
1193 (define (process-back-patches segment)
1194   (let loop ((prev      '())
1195              (remaining (segment-annotations segment))
1196              (next      (if (pair? (segment-annotations segment))
1197                             (cdr (segment-annotations segment))
1198                             #f)))
1199     (pk remaining)
1200 (if (pair? remaining)
1201     (let ((note (car remaining)))
1202       (letrec 
1203           ((fill-in 
1204             (lambda (function old-size)
1205               (let ((index (annotation-index note))
1206                     (posn  (annotation-posn note)))
1207                  (with-modified-segment-index-and-posn (segment index posn)
1208                    (segment-last-annotation-set! segment prev)
1209                    (function segment posn)
1210                    (let ((new-size (- (segment-current-index segment) index)))
1211                      (unless (= new-size old-size)
1212                        (merror "~S emitted ~W bytes, but claimed it was ~W."
1213                               note new-size old-size)))
1214                    (let ((tail (segment-last-annotation segment)))
1215                      (if tail
1216                          (set-cdr! tail next)
1217                          (segment-annotations-set! segment next)))
1218                    (set! next (cdr prev)))))))
1219         (cond ((back-patch? note)
1220                (fill-in (back-patch-fun  note)
1221                         (back-patch-size note)))
1222               ((chooser? note)
1223                (fill-in (chooser-worst-case-fun note)
1224                         (chooser-size note)))
1225               (else
1226                (set! prev remaining))))
1227       (loop prev next (cdr remaining))))))
1228
1229 ;;;; interface to the rest of the compiler
1230
1231 ;;; This holds the current segment while assembling. Use ASSEMBLE to
1232 ;;; change it.
1233 ;;;
1234 ;;; The double asterisks in the name are intended to suggest that this
1235 ;;; isn't just any old special variable, it's an extra-special
1236 ;;; variable, because sometimes MACROLET is used to bind it. So be
1237 ;;; careful out there..
1238 ;;;
1239 ;;; (This used to be called **CURRENT-SEGMENT** in SBCL until 0.7.3,
1240 ;;; and just *CURRENT-SEGMENT* in CMU CL. In both cases, the rebinding
1241 ;;; now done with MACROLET was done with SYMBOL-MACROLET instead. The
1242 ;;; rename-with-double-asterisks was because the SYMBOL-MACROLET made
1243 ;;; it an extra-special variable. The change over to
1244 ;;; %%CURRENT-SEGMENT%% was because ANSI forbids the use of label
1245 ;;; SYMBOL-MACROLET on special variable names, and CLISP correctly
1246 ;;; complains about this when being used as a bootstrap host.)
1247 (define-syntax-parameter %%current-segment%% 
1248   (lambda (x) 
1249     #'**current-segment**))
1250
1251 (define **current-segment** (make-fluid #f))
1252
1253 ;;; Just like %%CURRENT-SEGMENT%%, except this holds the current vop.
1254 ;;; This is used only to keep track of which vops emit which insts.
1255 ;;;
1256 ;;; The double asterisks in the name are intended to suggest that this
1257 ;;; isn't just any old special variable, it's an extra-special
1258 ;;; variable, because sometimes MACROLET is used to bind it. So be
1259 ;;; careful out there..
1260 (define-syntax-parameter %%current-vop%% 
1261   (lambda (x) #'**current-vop**))
1262
1263 (define **current-vop** (make-fluid #f))
1264
1265
1266 ;;; We also MACROLET %%CURRENT-SEGMENT%% to a local holding the
1267 ;;; segment so uses of %%CURRENT-SEGMENT%% inside the body don't have
1268 ;;; to keep dereferencing the symbol. Given that ASSEMBLE is the only
1269 ;;; interface to **CURRENT-SEGMENT**, we don't have to worry about the
1270 ;;; special value becomming out of sync with the lexical value. Unless
1271 ;;; some bozo closes over it, but nobody does anything like that...
1272 ;;;
1273 ;;; FIXME: The way this macro uses MACROEXPAND internally breaks my
1274 ;;; old assumptions about macros which are needed both in the host and
1275 ;;; the target. (This is more or less the same way that PUSH-IN,
1276 ;;; DELETEF-IN, and !DEF-BOOLEAN-ATTRIBUTE break my old assumptions,
1277 ;;; except that they used GET-SETF-EXPANSION instead of MACROEXPAND to
1278 ;;; do the dirty deed.) The quick and dirty "solution" here is the
1279 ;;; same as there: use cut and paste to duplicate the defmacro in a
1280 ;;; (SB!INT:DEF!MACRO FOO (..) .. CL:MACROEXPAND ..) #+SB-XC-HOST
1281 ;;; (DEFMACRO FOO (..) .. SB!XC:MACROEXPAND ..) idiom. This is
1282 ;;; disgusting and unmaintainable, and there are obviously better
1283 ;;; solutions and maybe even good solutions, but I'm disinclined to
1284 ;;; hunt for good solutions until the system works and I can test them
1285 ;;; in isolation.
1286 ;;;
1287 ;;; The above comment remains true, except that instead of a cut-and-paste
1288 ;;; copy we now have a macrolet. This is charitably called progress.
1289 ;;; -- NS 2008-09-19
1290
1291 (define (label-union x y)
1292   (define (in x l) 
1293     (let ((x (syntax->datum x)))
1294       (or-map (lambda (y) 
1295                 (eq? x (syntax->datum y))) 
1296               l)))
1297  
1298   (let loop ((x (if (pair? x) (label-union '() x) '()))
1299              (y y))
1300     (if (pair? y) 
1301         (if (in (car y) x)
1302             (loop x                (cdr y))
1303             (loop (cons (car y) x) (cdr y)))
1304         x)))
1305         
1306
1307
1308 (define-syntax assemble 
1309   (lambda (x)
1310     (define (defined-label? x)
1311       (let-values (((m x) (syntax-local-binding x)))
1312         (eq? m 'lexical)))
1313
1314     (syntax-case x ()
1315       ;;Cludge to simulate ((#:optional segment vop #:key labels) body ...)
1316       ((_ () . body)            #'(assemble (#f      #f  ()) . body))
1317       ((_ (segment    ) . body) #'(assemble (segment #f  ()) . body))
1318       ((_ (segment vop) . body) #'(assemble (segment vop ()) . body))
1319       ((_ (segment vop #:labels labels) . body) 
1320        #'(assemble (segment vop labels) . body))
1321       ((_ (segment #:labels labels) . body) 
1322        #'(assemble (segment #f labels) . body))
1323       ((_ (#:labels labels) . body) 
1324        #'(assemble (#f #f labels) . body))
1325
1326
1327       ((_ (segment vop (labels ...)) body ...)
1328         (let ()          
1329           (define (not-label-name? thing)
1330             (let ((thing (syntax->datum thing)))
1331               (not (and thing (symbol? thing)))))
1332
1333           (let* ((seg-var        (datum->syntax x  (gensym "segment-")))
1334                  (vop-var        (datum->syntax x  (gensym "vop-")))
1335                  (visible-labels (remove not-label-name? #'(body ...)))
1336                  (new-labels 
1337                   (remove defined-label?
1338                           (label-union #'(labels ...)
1339                                        visible-labels))))
1340        (with-syntax ((seg-var seg-var) (vop-var vop-var))
1341          (pp #`(let* ((seg-var #,(if (syntax->datum #'segment)
1342                                  #'segment
1343                                  #'(fluid-ref %%current-segment%%)))
1344                   (vop-var #,(if (syntax->datum #'vop)
1345                                  #'vop
1346                                  #'(fluid-ref %%current-vop%%))))
1347              (with-fluids(
1348                           #,@(if (syntax->datum #'segment)
1349                                  #`((**current-segment** 
1350                                      seg-var))
1351                                  '())
1352                           #,@(if (syntax->datum #'vop)
1353                                  #`((**current-vop** 
1354                                      vop-var))
1355                                  '()))
1356                 (let* (
1357                        #,@(map (lambda (name)
1358                                  #`(#,name (gen-label)))
1359                                new-labels))
1360                   
1361                   (syntax-parameterize
1362                    ((%%current-segment%% (lambda (x) #'seg-var))
1363                     (%%current-vop%%     (lambda (x) #'vop-var)))
1364                    #,@(map (lambda (form)
1365                             (if (not (not-label-name? form))
1366                                 #`(emit-label #,form)
1367                                 form))
1368                           #'(body ...))))))))))))))
1369
1370 (define-syntax inst 
1371   (lambda (x)
1372     (syntax-case x ()
1373       ((_  instruction  args ...)
1374        (let* ((ins  (syntax->datum #'instruction))
1375               (inst (hash-ref *assem-instructions* ins)))
1376          (cond ((not inst)
1377                 (merror "unknown instruction: ~S" 
1378                         (syntax->datum #'instruction)))
1379                ((procedure? inst)
1380                 (inst (stx-cdr x)))
1381                (else
1382                 #`(#,inst %%current-segment%% %%current-vop%% args ...))))))))
1383
1384
1385 ;;; Note: The need to capture MACROLET bindings of %%CURRENT-SEGMENT%%
1386 ;;; and %%CURRENT-VOP%% prevents this from being an ordinary function.
1387 (define-syntax-rule (emit-label label)
1388   (%emit-label %%current-segment%% %%current-vop%% label))
1389
1390 ;;; Note: The need to capture MACROLET bindings of
1391 ;;; %%CURRENT-SEGMENT%% prevents this from being an ordinary function.
1392 (define-syntax-rule (emit-postit function)
1393   (%emit-postit %%current-segment%% function))
1394
1395 ;;; Note: The need to capture SYMBOL-MACROLET bindings of
1396 ;;; **CURRENT-SEGMENT* and (%%CURRENT-VOP%%) prevents this from being an
1397 ;;; ordinary function.
1398 (define-syntax emit-alignment 
1399   (syntax-rules ()
1400     ((_ bits)
1401      (emit-alignment bits 0))
1402     ((_ bits fill-byte)
1403      (%emit-alignment %%current-segment%%
1404                       %%current-vop%%
1405                       bits fill-byte))))
1406
1407
1408
1409 (define* (label-position label #:optional (if-after #f) (delta 0))
1410   "Return the current position for LABEL. Chooser maybe-shrink functions
1411    should supply IF-AFTER and DELTA in order to ensure correct results."
1412   (let ((posn (annotation-posn label)))
1413     (if (and if-after (> posn if-after))
1414         (- posn delta)
1415         posn)))
1416
1417
1418 (define (append-segment segment other-segment)
1419   "Append OTHER-SEGMENT to the end of SEGMENT. Don't use OTHER-SEGMENT
1420    for anything after this."
1421   (when (segment-run-scheduler segment)
1422         (schedule-pending-instructions segment))
1423   (let ((postits (segment-postits segment)))
1424     (segment-postits-set! segment (segment-postits other-segment))
1425     (dolist (postit postits)
1426             (emit-back-patch segment 0 postit)))
1427
1428   (when (not (or x86 x86-64))
1429         (%emit-alignment segment #f max-alignment))
1430
1431   (when (or x86 x86-64)
1432         (unless (eq? #:elsewhere (segment-type other-segment))
1433                 (%emit-alignment segment #f max-alignment)))
1434
1435   (let ((segment-current-index-0 (segment-current-index segment))
1436         (segment-current-posn-0  (segment-current-posn  segment)))
1437     (segment-current-index-set! 
1438      segment
1439      (+ (segment-current-index segment) 
1440         (segment-current-index other-segment)))
1441
1442     (bytevector-copy! (segment-buffer segment)       
1443                       segment-current-index-0
1444
1445                       (segment-buffer other-segment) 0
1446
1447                       (segment-current-index other-segment))
1448
1449     (segment-buffer-set! other-segment #f) ; to prevent accidental reuse
1450
1451     (segment-current-posn-set!
1452      segment
1453      (+ (segment-current-posn segment)
1454         (segment-current-posn other-segment)))
1455
1456     (let ((other-annotations (segment-annotations other-segment)))
1457       (when other-annotations
1458         (dolist (note other-annotations)
1459           (annotation-index-set! 
1460            note
1461            (+ (annotation-index note) segment-current-index-0))
1462
1463           (annotation-posn-set!
1464            note
1465            (+ (annotation-posn note) segment-current-posn-0))
1466
1467           ;; This SEGMENT-LAST-ANNOTATION code is confusing. Is it really
1468           ;; worth enough in efficiency to justify it? -- WHN 19990322
1469           (let ((last (segment-last-annotation segment)))
1470             (if (pair? last)
1471                 (set-cdr! last other-annotations)
1472                 (segment-annotations-set! segment other-annotations)))
1473
1474           (segment-last-annotation-set! 
1475            segment
1476            (segment-last-annotation other-segment))))))
1477   (values))
1478
1479
1480
1481 (define (finalize-segment segment)
1482   "Do any final processing of SEGMENT and return the total number of bytes
1483    covered by this segment."
1484   (when (segment-run-scheduler segment)
1485         (schedule-pending-instructions segment))
1486   (segment-run-scheduler-set! segment #f)
1487   (let ((postits (segment-postits segment)))
1488     (segment-postits-set! segment '())
1489     (dolist (postit postits)
1490             (emit-back-patch segment 0 postit)))
1491
1492   (segment-final-index-set! segment (segment-current-index segment))
1493   (segment-final-posn-set!  segment (segment-current-posn segment))
1494   (segment-inst-hook-set!   segment #f)
1495   #;(compress-output segment)
1496   (finalize-positions segment)
1497   (process-back-patches segment)
1498   (segment-final-posn segment))
1499
1500 ;;; Call FUNCTION on all the stuff accumulated in SEGMENT. FUNCTION
1501 ;;; should accept a single vector argument. It will be called zero or
1502 ;;; more times on vectors of the appropriate byte type. The
1503 ;;; concatenation of the vector arguments from all the calls is the
1504 ;;; contents of SEGMENT.
1505 ;;;
1506 ;;; KLUDGE: This implementation is sort of slow and gross, calling
1507 ;;; FUNCTION repeatedly and consing a fresh vector for its argument
1508 ;;; each time. It might be possible to make a more efficient version
1509 ;;; by making FINALIZE-SEGMENT do all the compacting currently done by
1510 ;;; this function: then this function could become trivial and fast,
1511 ;;; calling FUNCTION once on the entire compacted segment buffer. --
1512 ;;; WHN 19990322
1513 (define (on-segment-contents-vectorly segment function)
1514   (let ((buffer (segment-buffer segment))
1515         (i0 0))
1516     (define (frob i0 i1)
1517       (when (< i0 i1)
1518             (function (subseq buffer i0 i1))))
1519     (dolist (note (segment-annotations segment))
1520             (when (filler? note)
1521                   (let ((i1 (annotation-index note)))
1522                     (frob i0 i1)
1523                     (set! i0 (+ i1 (filler-bytes note))))))
1524     (frob i0 (segment-final-index segment)))
1525   (values))
1526
1527 ;;; Write the code accumulated in SEGMENT to STREAM, and return the
1528 ;;; number of bytes written.
1529 (define (write-segment-contents segment stream)
1530   (let ((result 0))
1531     (on-segment-contents-vectorly 
1532      segment
1533      (lambda (v)
1534        (set! result (+ result (length v)))
1535        (write-sequence v stream)))
1536     result))
1537
1538 ;;;; interface to the instruction set definition
1539
1540 ;;; Define a function named NAME that merges its arguments into a
1541 ;;; single integer and then emits the bytes of that integer in the
1542 ;;; correct order based on the endianness of the target-backend.
1543 (define (p x) (pk (number->string x 2)) x)
1544
1545 (define (mk-contents total-bits ar exprs specs is)
1546   (let* ((overall-mask (ash -1 total-bits))
1547          (num-bytes    (let-values (((quo rem)
1548                                      (euclidean/ total-bits
1549                                                  assembly-unit-bits)))
1550
1551                          (unless (zero? rem)
1552                                  (merror "~W isn't an even multiple of ~W."
1553                                          total-bits assembly-unit-bits))
1554                          quo))
1555          (bytes        (make-vector num-bytes '())))
1556
1557     (define (push x i)
1558       (vector-set! 
1559        bytes i 
1560        (cons x (vector-ref bytes i))))
1561                    
1562     (define (add-content expr spec i)
1563       (let* (       
1564              (spec expr)
1565              (size (byte-size     spec))
1566              (posn (byte-position spec)))
1567
1568     (when (ldb-test (byte size posn) overall-mask)
1569           (merror "The byte spec ~S either overlaps another byte spec, or ~%extends past the end."
1570                   spec))
1571
1572     (ldb-set! spec overall-mask -1)
1573     (let-values  (((start-byte offset)
1574                    (floor/ posn assembly-unit-bits)))
1575       (let ((end-byte (floor/ (1- (+ posn size))
1576                              assembly-unit-bits))
1577             (maybe-ash (lambda (expr offset)
1578                          (if (zero? offset)
1579                              expr
1580                              (lambda () 
1581                                (ash (expr) offset))))))
1582         (cond ((zero? size))
1583               ((= start-byte end-byte)
1584                (push (maybe-ash 
1585                       (lambda () (ldb (byte size 0) (vector-ref ar i)))
1586                       offset)
1587                      start-byte))
1588               (else
1589                (push (maybe-ash
1590                       (lambda ()
1591                         (ldb (byte (- assembly-unit-bits offset) 0)
1592                              (vector-ref ar i)))
1593                       offset)
1594                      start-byte)
1595
1596                (let loop ((index (+ 1 start-byte)))
1597                  (if (< index end-byte)
1598                      (begin
1599                        (push
1600                         (lambda ()
1601                           (ldb (byte assembly-unit-bits
1602                                      (- (* assembly-unit-bits
1603                                            (- index start-byte))
1604                                         offset))
1605                                (vector-ref ar i)))
1606                         index)
1607                        (loop (+ 1 index)))))
1608
1609                (let ((len (remainder (+ size offset)
1610                                      assembly-unit-bits)))                 
1611                    (push
1612                     (lambda ()
1613                       (ldb (byte (if (zero? len)
1614                                      assembly-unit-bits
1615                                      len)
1616                                  (- (* assembly-unit-bits
1617                                        (- end-byte start-byte))
1618                                     offset))
1619                            (vector-ref ar i)))
1620                     end-byte))))))))
1621
1622     (for-each add-content exprs specs is)
1623     
1624     (unless (= overall-mask -1)
1625             (error "There are holes."))
1626     
1627     (let ((forms '()))
1628       (let loop ((i 0) (r '()))
1629         (if (< i num-bytes)
1630             (let ((pieces (vector-ref bytes i)))
1631               (aver (pair? pieces))
1632               (loop (+ i 1)
1633                     (cons
1634                      (if (pair? pieces)
1635                          (lambda (segment)
1636                            (emit-byte segment
1637                                       (let loop ((p (cdr pieces))
1638                                                  (r ((car pieces))))
1639                                         (if (pair? p)
1640                                             (loop (cdr p) (logior r ((car p))))
1641                                             r))))
1642                          (lambda (segment)
1643                            (emit-byte segment ((car pieces)))))
1644                      r)))
1645             (case *backend-byte-order*
1646               ((#:little-endian) r)
1647               ((#:big-endian)    (reverse r))
1648               ((#f) 
1649                (warn "*backend-byte-order* has not ben setted in backend code")
1650                r)))))))
1651               
1652
1653
1654 (define-syntax define-bitfield-emitter 
1655   (lambda (x)
1656    (syntax-case x ()
1657      ((_ name total-bits  byte-specs ...)
1658       (with-syntax (((arg-names ...) (map (lambda (x) 
1659                                             (datum->syntax #'name 
1660                                                            (gensym "arg")))
1661                                           #'(byte-specs ...)))
1662                     
1663                     ((i         ...) (let loop ((i 0) (bc #'(byte-specs ...)))
1664                                        (if (pair? bc)
1665                                            (cons i (loop (+ i 1) (cdr bc)))
1666                                            '())))                   
1667                     (n               (length #'(byte-specs ...)))
1668                     ((specs     ...) (map (lambda (x)
1669                                             #`(quote #,x))
1670                                           #'(byte-specs ...)))
1671                     (ar              (datum->syntax #'name (gensym "ar")))
1672                     (segment-arg  (datum->syntax #'name (gensym "SEGMENT-"))))
1673                                        
1674         #'(define name 
1675             (let* ((tot  total-bits)
1676                    (ar   (make-vector n))
1677                    (fs   (mk-contents tot ar 
1678                                       (list byte-specs ...) 
1679                                       (list specs     ...) 
1680                                       (list i         ...))))
1681               (lambda (segment-arg arg-names ...)
1682                 (vector-set! ar i arg-names) ...
1683                 (for-each (lambda (x) (x segment-arg)) fs)
1684                 'name))))))))
1685
1686 (define (nu x) (if (null? x) #''() x))
1687 (define (grovel-lambda-list stx lambda-list vop-var)
1688   (define (gensm x) (datum->syntax stx (gensym x)))
1689   (let* ((lambda-list  (stx->list lambda-list))
1690          (segment-name (stx-car lambda-list))
1691          (vop-var      (or vop-var (gensm "vop"))))
1692     (let ((new-lambda-list '()))
1693       (define (collect x) (set! new-lambda-list (cons x new-lambda-list)))
1694       (collect segment-name)
1695       (collect vop-var)
1696       (letrec
1697           ((grovel 
1698             (lambda (state lambda-list)
1699               (if (stx-pair? lambda-list)
1700                 (let ((param (stx->list (stx-car lambda-list))))
1701                   (cond
1702                    ((keyword? (syntax->datum param))
1703                     (collect param)
1704                     (grovel (syntax->datum param) (stx-cdr lambda-list)))
1705                    (else
1706                    (case state
1707                      ((#f)
1708                       (collect param)
1709                       #`(cons #,param #,(let ((a 
1710                                                (grovel state 
1711                                                        (stx-cdr lambda-list))))
1712                                           (if (null? a)
1713                                               #''()
1714                                               a))))
1715
1716                      ((#:optional)
1717                       (let-values (((name default supplied?)
1718                                     (if (stx-pair? param)
1719                                         (values (car  param)
1720                                                 (cadr param)
1721                                                 (if (pair? (cddr param))
1722                                                     (caddr param)
1723                                                     (gensm "supplied?-")))
1724                                         (values param 
1725                                                 '()
1726                                                 (gensm "supplied?-")))))
1727                         (collect (list name default supplied?))
1728                         #`(and #,supplied?
1729                                (cons #,(if (pair? name)
1730                                            (cadr name)
1731                                            name)
1732                                      #,(nu (grovel state 
1733                                                    (stx-cdr lambda-list)))))))
1734                      ((#:key)
1735                       (let-values (((name default supplied?)
1736                                     (if (pair? param)
1737                                         (values (car  param)
1738                                                 (cadr param)
1739                                                 (if (pair? (cddr param))
1740                                                     (caddr param)
1741                                                     (gensm "supplied?-")))
1742                                         (values param 
1743                                                 '()
1744                                                 (gensm "supplied?-")))))
1745
1746                         (collect (list name default supplied?))
1747                         (let-values (((key var)
1748                                       (if (pair? name)
1749                                           (values (car name) (cadr name))
1750                                           (values (symbol->keyword 
1751                                                    name) name))))
1752                           #`(append (and #,supplied? (list #',key #,var))
1753                                     #,(grovel state (stx-cdr lambda-list))))))
1754                      ((#:rest)
1755                       (collect param)
1756                       (grovel state (stx-cdr lambda-list))
1757                       param)))))
1758                 #'()))))
1759         (let ((reconstructor (nu (grovel #f (stx-cdr lambda-list)))))
1760           (values (reverse new-lambda-list)
1761                   segment-name
1762                   vop-var
1763                   reconstructor))))))
1764
1765
1766 (define (extract-nths index glue list-of-lists-of-lists)
1767   (map (lambda (list-of-lists)
1768          (cons glue
1769                (map (lambda (list)
1770                       (list-ref list index))
1771                     list-of-lists)))
1772        list-of-lists-of-lists))
1773
1774
1775 (define (handle-options name options)
1776   (define (get-items x)
1777     (syntax-case x ()
1778       ((n args ...)
1779        (values (syntax->datum #'n) #'(args ...)))
1780       (n 
1781        (values (syntax->datum #'n) '()))))
1782
1783   (let*  ((vop-var      #f)
1784           (emitter      #f)
1785           (decls        '())
1786           (attributes   '())
1787           (cost         #f)
1788           (dependencies '())
1789           (ddelay       #f)
1790           (pinned       #f)
1791           (pdefs        '()))
1792     (for-each 
1793      (lambda (x)
1794        (let-values (((key args) (get-items x)))
1795          (case key
1796            ((:emitter)
1797             (when emitter
1798                   (error "You can only specify :EMITTER once per instruction."))
1799             (set! emitter args))
1800            ((:declare)
1801             (set! decls (append decls args)))
1802            ((:attributes)
1803             (set! attributes (append attributes args)))
1804            ((:cost)
1805             (set! cost (first args)))
1806            ((:dependencies)
1807             (set! dependencies (append dependencies args)))
1808            ((:delay)
1809             (when ddelay
1810                   (error "You can only specify :DELAY once per instruction."))
1811             (set! ddelay args))
1812            ((:pinned)
1813             (set! pinned #t))
1814            ((:vop-var)
1815             (if vop-var
1816                (error "You can only specify :VOP-VAR once per instruction.")
1817                (set! vop-var (car args))))
1818           ((:printer)
1819            (push #`((xx
1820                     #,(gen-printer-def-forms-def-form
1821                        name                        
1822                        #'(let ((*print-right-margin* 1000)
1823                                (format #f "~@:(~A[~A]~)" '#,name #,args)))
1824                        (stx-cdr x))))
1825                  pdefs))
1826           ((:printer-list)
1827            ;; same as :PRINTER, but is EVALed first, and is a list of
1828            ;; printers
1829            (push
1830             #'(xx 
1831                (map (lambda (printer)
1832                       #,(sb!disassem:gen-printer-def-forms-def-form
1833                          #'name
1834                          #'(let ((*print-right-margin* 1000))
1835                              (format #f "~@:(~A[~A]~)" 
1836                                      '#,name #,printer))
1837                          printer
1838                          #f))
1839                     #,(cadr x)))
1840             pdefs))
1841           (else
1842            (error "unknown option: ~S" options)))))
1843      options)
1844     (values vop-var emitter decls attributes cost dependencies
1845             ddelay pinned pdefs)))
1846    
1847
1848 (define (pp x) (pretty-print (syntax->datum x)) x)
1849
1850 (define-syntax define-instruction
1851   (lambda (x)
1852     (syntax-case x ()
1853       ((_ name lambda-list options ...)
1854        (let ((sym-name (symbol->string (syntax->datum #'name)))
1855              (postits  (datum->syntax #'name (gensym "postits"))))
1856          (define (gen x) 
1857            (datum->syntax #'name (string->symbol x)))
1858          
1859        (let-values  (((vop-var emitter decls attributes cost 
1860                        dependencies ddelay pinned pdefs)
1861                       (handle-options #'name #'(options ...))))
1862        (let-values
1863                      (((new-lambda-list segment-name vop-name arg-reconstructor)
1864                        (grovel-lambda-list #'name #'lambda-list vop-var)))
1865          (set! pdefs (reverse pdefs))
1866          (unless cost (set! cost 1))
1867          (push #`(let ((hook (segment-inst-hook #,segment-name)))
1868                    (when hook
1869                          (hook #,segment-name #,vop-name #,sym-name
1870                                #,arg-reconstructor)))
1871                emitter)
1872          (push #`(dolist (postit #,postits)
1873                          (emit-back-patch #,segment-name 0 postit))
1874                emitter)
1875
1876       (when *dyncount*
1877             (push #`(when (segment-collect-dynamic-statistics #,segment-name)
1878                           (let* ((info (ir2-component-dyncount-info
1879                                         (component-info
1880                                          *component-being-compiled*))))
1881                             (costs (dyncount-info-costs info))
1882                             (block-number (block-number
1883                                            (ir2-block-block
1884                                             (vop-block #,vop-name)))))
1885                           (vector-set costs block-number
1886                                       (+
1887                                        (vector-ref costs block-number
1888                                                    #,cost))))
1889                   emitter))
1890
1891       (when *assem-scheduler?*
1892         (if pinned
1893             (set! emitter
1894                   #`((when (segment-run-scheduler #,segment-name)
1895                            (schedule-pending-instructions #,segment-name))
1896                      #,@emitter))
1897             (let ((flet-name
1898                    (gen (string-append "emit-" sym-name "-inst-")))
1899                   (inst-name (datum->syntax #'name (gensym "inst-"))))
1900               (set! emitter 
1901                     #`((letrec ((#,flet-name 
1902                                  (lambda (#,segment-name)
1903                                    ,@emitter)))
1904                          (if (segment-run-scheduler #,segment-name)
1905                              (let ((#,inst-name
1906                                     (make-instruction
1907                                      (incf (segment-inst-number
1908                                             ,segment-name))
1909                                      #,flet-name
1910                                      (instruction-attributes
1911                                       ,@attributes)
1912                                      (progn ,@ddelay))))
1913                                #,@(if dependencies
1914                                       #`((note-dependencies
1915                                           (#,segment-name #,inst-name)
1916                                           #,@dependencies))
1917                                       '())
1918                                (queue-inst #,segment-name #,inst-name))
1919                              (#,flet-name #,segment-name))))))))
1920
1921       (with-syntax ((defun-name  (gen (string-append sym-name
1922                                                      "-inst-emitter"))))
1923        
1924         #`(begin
1925          (define defun-name 
1926            (lambda** #,new-lambda-list
1927              (let ((#,postits (segment-postits #,segment-name)))
1928                ;; Must be done so that contribs and user code doing
1929                ;; low-level stuff don't need to worry about this.
1930                (segment-postits-set! #,segment-name '())
1931                (let ()
1932                  (syntax-parameterize
1933                   ((%%current-segment%% 
1934                     (lambda (x)
1935                       (error "You can't use INST without an ASSEMBLE inside emitters."))))
1936                   ;; KLUDGE: Some host lisps (CMUCL 18e Sparc at least)
1937                   ;; can't deal with this declaration, so disable it on host
1938                   ;; Ditto for earlier ENABLE-PACKAGE-LOCKS %%C-S%% %%C-V%%
1939                   ;; declaration.
1940                   #,@emitter)))
1941              (values)))
1942
1943          
1944          (%define-instruction 'name #'defun-name)
1945
1946          #|
1947          #,@(extract-nths 1 #'begin pdefs)
1948          #,@(if (pair? pdefs)
1949                 #`((install-inst-flavors
1950                     'name
1951                     (append #,@(extract-nths 0 #'list pdefs))))
1952                 '())
1953          |#)))))))))
1954
1955
1956 (define (%define-instruction name defun)
1957   (hash-set! *assem-instructions* name defun)
1958   name)
1959