/[cmucl]/src/compiler/new-assem.lisp
ViewVC logotype

Contents of /src/compiler/new-assem.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.37 - (hide annotations)
Tue Apr 20 17:57:46 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.36: +34 -34 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 wlott 1.1 ;;; -*- Package: NEW-ASSEM -*-
2     ;;;
3     ;;; **********************************************************************
4     ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;;
7     (ext:file-comment
8 rtoy 1.37 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/new-assem.lisp,v 1.37 2010/04/20 17:57:46 rtoy Rel $")
9 wlott 1.1 ;;;
10     ;;; **********************************************************************
11     ;;;
12     ;;; Effecient retargetable scheduling assembler.
13     ;;;
14     ;;; Written by William Lott.
15     ;;;
16     (in-package :new-assem)
17 wlott 1.12
18 wlott 1.17 (in-package :c)
19 rtoy 1.35 (intl:textdomain "cmucl")
20    
21 wlott 1.17 (import '(branch flushable) :new-assem)
22     (import '(sset-element sset make-sset do-elements
23     sset-adjoin sset-delete sset-empty)
24     :new-assem)
25 wlott 1.1
26 wlott 1.17 (in-package :new-assem)
27 wlott 1.2 (export '(emit-byte emit-skip emit-back-patch emit-chooser emit-postit
28 wlott 1.1 define-emitter define-instruction define-instruction-macro
29 toy 1.31 def-assembler-params branch flushable variable-length
30 wlott 1.1
31 hallgren 1.22 segment make-segment segment-name segment-collect-dynamic-statistics
32 hallgren 1.11 assemble align inst without-scheduling
33 wlott 1.1 label label-p gen-label emit-label label-position
34     append-segment finalize-segment
35     segment-map-output release-segment))
36    
37    
38     ;;;; Assembly control parameters.
39    
40     (defstruct (assem-params
41     (:print-function %print-assem-params))
42     (backend (ext:required-argument) :type c::backend)
43     (scheduler-p nil :type (member t nil))
44 wlott 1.17 (instructions (make-hash-table :test #'equal) :type hash-table)
45     (max-locations 0 :type index))
46 wlott 1.1 ;;;
47     (c::defprinter assem-params
48     (backend :prin1 (c:backend-name backend)))
49    
50     ;;; DEF-ASSEMBLER-PARAMS -- Interface.
51     ;;;
52     (defmacro def-assembler-params (&rest options)
53 rtoy 1.36 "Set up the assembler."
54 toy 1.30 `(eval-when (:compile-toplevel :load-toplevel :execute)
55 wlott 1.1 (setf (c:backend-assembler-params c:*target-backend*)
56     (make-assem-params :backend c:*target-backend*
57     ,@options))))
58    
59    
60     ;;;; Constants.
61    
62     ;;; ASSEMBLY-UNIT-BITS -- Number of bits in the minimum assembly unit,
63     ;;; (also refered to as a ``byte''). Hopefully, different instruction
64 toy 1.32 ;;; sets won't require changing this.
65 wlott 1.1 ;;;
66     (defconstant assembly-unit-bits 8)
67    
68     (deftype assembly-unit ()
69     `(unsigned-byte ,assembly-unit-bits))
70    
71     ;;; OUTPUT-BLOCK-SIZE -- The size (in bytes) to use per output block. Each
72     ;;; output block is a chunk of raw memory, pointed to by a sap.
73     ;;;
74     (defconstant output-block-size (* 8 1024))
75    
76     (deftype output-block-index ()
77     `(integer 0 ,output-block-size))
78    
79     ;;; MAX-ALIGNMENT -- The maximum alignment we can guarentee given the object
80     ;;; format. If the loader only loads objects 8-byte aligned, we can't do
81 cwang 1.34 ;;; any better than that ourselves.
82 wlott 1.1 ;;;
83     (defconstant max-alignment 3)
84    
85     (deftype alignment ()
86     `(integer 0 ,max-alignment))
87    
88     ;;; MAX-INDEX -- The maximum an index will ever become. Well, actually,
89     ;;; just a bound on it so we can define a type. There is no real hard
90     ;;; limit on indexes, but we will run out of memory sometime.
91     ;;;
92     (defconstant max-index (1- most-positive-fixnum))
93    
94     (deftype index ()
95     `(integer 0 ,max-index))
96    
97     ;;; MAX-POSN -- Like MAX-INDEX, except for positions.
98     ;;;
99     (defconstant max-posn (1- most-positive-fixnum))
100    
101     (deftype posn ()
102     `(integer 0 ,max-posn))
103    
104    
105    
106     ;;;; The SEGMENT structure.
107    
108     ;;; SEGMENT -- This structure holds the state of the assembler.
109     ;;;
110     (defstruct (segment
111     (:print-function %print-segment)
112     (:constructor make-segment (&key name run-scheduler inst-hook)))
113     ;;
114     ;; The name of this segment. Only using in trace files.
115     (name "Unnamed" :type simple-base-string)
116     ;;
117 hallgren 1.22 ;; Whether or not run the scheduler. Note: if the instruction defintions
118 wlott 1.1 ;; were not compiled with the scheduler turned on, this has no effect.
119     (run-scheduler nil)
120     ;;
121     ;; If a function, then it is funcalled for each inst emitted with the
122     ;; segment, the VOP, the name of the inst (as a string), and the inst
123     ;; arguments.
124     (inst-hook nil :type (or function null))
125     ;;
126     ;; Where to deposit the next byte.
127     (fill-pointer (system:int-sap 0) :type system:system-area-pointer)
128     ;;
129     ;; Where the current output block ends. If fill-pointer is ever sap= to
130     ;; this, don't deposit a byte. Move the fill pointer into a new block.
131     (block-end (system:int-sap 0) :type system:system-area-pointer)
132     ;;
133     ;; What position does this correspond to. Initially, positions and indexes
134     ;; are the same, but after we start collapsing choosers, positions can change
135     ;; while indexes stay the same.
136     (current-posn 0 :type posn)
137     ;;
138     ;; Were in the output blocks are we currently outputing.
139     (current-index 0 :type index)
140     ;;
141     ;; A vector of the output blocks.
142     (output-blocks (make-array 4 :initial-element nil) :type simple-vector)
143     ;;
144     ;; A list of all the annotations that have been output to this segment.
145     (annotations nil :type list)
146     ;;
147     ;; A pointer to the last cons cell in the annotations list. This is
148     ;; so we can quickly add things to the end of the annotations list.
149     (last-annotation nil :type list)
150     ;;
151     ;; The number of bits of alignment at the last time we synchronized.
152     (alignment max-alignment :type alignment)
153     ;;
154     ;; The position the last time we synchronized.
155     (sync-posn 0 :type posn)
156     ;;
157     ;; The posn and index everything ends at. This is not maintained while the
158     ;; data is being generated, but is filled in after. Basically, we copy
159     ;; current-posn and current-index so that we can trash them while processing
160     ;; choosers and back-patches.
161     (final-posn 0 :type posn)
162     (final-index 0 :type index)
163     ;;
164     ;; *** State used by the scheduler during instruction queueing.
165     ;;
166 wlott 1.2 ;; List of postit's. These are accumulated between instructions.
167     (postits nil :type list)
168     ;;
169 wlott 1.17 ;; ``Number'' for last instruction queued. Used only to supply insts
170     ;; with unique sset-element-number's.
171     (inst-number 0 :type index)
172 wlott 1.1 ;;
173 wlott 1.17 ;; Simple-Vectors mapping locations to the instruction that reads them and
174     ;; instructions that write them.
175     (readers (make-array (assem-params-max-locations
176     (c:backend-assembler-params c:*backend*))
177     :initial-element nil)
178     :type simple-vector)
179     (writers (make-array (assem-params-max-locations
180     (c:backend-assembler-params c:*backend*))
181     :initial-element nil)
182     :type simple-vector)
183     ;;
184 wlott 1.1 ;; The number of additional cycles before the next control transfer, or NIL
185     ;; if a control transfer hasn't been queued. When a delayed branch is
186     ;; queued, this slot is set to the delay count.
187     (branch-countdown nil :type (or null (and fixnum unsigned-byte)))
188     ;;
189     ;; *** These two slots are used both by the queuing noise and the
190     ;; scheduling noise.
191     ;;
192 wlott 1.17 ;; All the instructions that are pending and don't have any unresolved
193     ;; dependents. We don't list branches here even if they would otherwise
194     ;; qualify. They are listed above.
195 wlott 1.1 ;;
196 wlott 1.17 (emittable-insts-sset (make-sset) :type sset)
197 wlott 1.1 ;;
198     ;; List of queued branches. We handle these specially, because they have to
199     ;; be emitted at a specific place (e.g. one slot before the end of the
200     ;; block).
201     (queued-branches nil :type list)
202     ;;
203     ;; *** State used by the scheduler duing instruction scheduling.
204     ;;
205     ;; The instructions who would have had a read dependent removed if it were
206     ;; not for a delay slot. This is a list of lists. Each element in the
207     ;; top level list corresponds to yet another cycle of delay. Each element
208     ;; in the second level lists is a dotted pair, holding the dependency
209     ;; instruction and the dependent to remove.
210 wlott 1.17 (delayed nil :type list)
211     ;;
212     ;; The emittable insts again, except this time as a list sorted by depth.
213 hallgren 1.22 (emittable-insts-queue nil :type list)
214     ;;
215     ;; Whether or not to collect dynamic statistics. This is just the same as
216     ;; *collect-dynamic-statistics* but is faster to reference.
217     (collect-dynamic-statistics nil))
218 wlott 1.1
219     (c::defprinter segment name)
220    
221    
222     ;;;; Structures/types used by the scheduler.
223    
224     (c:def-boolean-attribute instruction
225     ;;
226     ;; This attribute is set if the scheduler can freely flush this instruction
227     ;; if it thinks it is not needed. Examples are NOP and instructions that
228     ;; have no side effect not described by the writes.
229     flushable
230     ;;
231     ;; This attribute is set when an instruction can cause a control transfer.
232     ;; For test instructions, the delay is used to determine how many
233     ;; instructions follow the branch.
234     branch
235 wlott 1.21 ;;
236     ;; This attribute indicates that this ``instruction'' can be variable length,
237     ;; and therefore better never be used in a branch delay slot.
238     variable-length
239 wlott 1.1 )
240    
241     (defstruct (instruction
242 wlott 1.17 (:include sset-element)
243 wlott 1.1 (:print-function %print-instruction)
244     (:conc-name inst-)
245 wlott 1.17 (:constructor make-instruction (number emitter attributes delay)))
246 wlott 1.1 ;;
247     ;; The function to envoke to actually emit this instruction. Gets called
248     ;; with the segment as its one argument.
249     (emitter (required-argument) :type (or null function))
250     ;;
251     ;; The attributes of this instruction.
252     (attributes (instruction-attributes) :type c:attributes)
253     ;;
254     ;; Number of instructions or cycles of delay before additional instructions
255     ;; can read our writes.
256     (delay 0 :type (and fixnum unsigned-byte))
257     ;;
258     ;; The maximum number of instructions in the longest dependency chain from
259     ;; this instruction to one of the independent instructions. This is used
260     ;; as a heuristic at to which instructions should be scheduled first.
261     (depth nil :type (or null (and fixnum unsigned-byte)))
262     ;;
263     ;; ** When trying remember which of the next four is which, note that the
264     ;; ``read'' or ``write'' always referes to the dependent (second)
265     ;; instruction.
266     ;;
267 wlott 1.17 ;; Instructions whos writes this instruction tries to read.
268     (read-dependencies (make-sset) :type sset)
269 wlott 1.1 ;;
270 wlott 1.17 ;; Instructions whos writes or reads are overwritten by this instruction.
271     (write-dependencies (make-sset) :type sset)
272 wlott 1.1 ;;
273 wlott 1.17 ;; Instructions who write what we read or write.
274     (write-dependents (make-sset) :type sset)
275 wlott 1.1 ;;
276 wlott 1.17 ;; Instructions who read what we write.
277     (read-dependents (make-sset) :type sset))
278 wlott 1.1 ;;;
279 wlott 1.13 #+debug (defvar *inst-ids* (make-hash-table :test #'eq))
280     #+debug (defvar *next-inst-id* 0)
281 wlott 1.1 (defun %print-instruction (inst stream depth)
282     (declare (ignore depth))
283     (print-unreadable-object (inst stream :type t :identity t)
284 wlott 1.13 #+debug
285 wlott 1.1 (princ (or (gethash inst *inst-ids*)
286     (setf (gethash inst *inst-ids*)
287     (incf *next-inst-id*)))
288     stream)
289 wlott 1.13 (format stream #+debug " emitter=~S" #-debug "emitter=~S"
290 wlott 1.14 (let ((emitter (inst-emitter inst)))
291     (if emitter
292     (multiple-value-bind
293     (lambda lexenv-p name)
294     (function-lambda-expression emitter)
295     (declare (ignore lambda lexenv-p))
296     name)
297 toy 1.31 "<flushed>")))
298 wlott 1.1 (when (inst-depth inst)
299     (format stream ", depth=~D" (inst-depth inst)))))
300    
301 wlott 1.13 #+debug
302 wlott 1.1 (defun reset-inst-ids ()
303     (clrhash *inst-ids*)
304     (setf *next-inst-id* 0))
305    
306    
307     ;;;; The scheduler itself.
308    
309     ;;; WITHOUT-SCHEDULING -- interface.
310     ;;;
311 toy 1.30 (defmacro without-scheduling ((&optional (segment '(%%current-segment%%)))
312 wlott 1.1 &body body)
313 rtoy 1.36 "Execute BODY (as a progn) without scheduling any of the instructions
314 wlott 1.1 generated inside it. DO NOT throw or return-from out of it."
315     (let ((var (gensym))
316     (seg (gensym)))
317     `(let* ((,seg ,segment)
318     (,var (segment-run-scheduler ,seg)))
319     (when ,var
320     (schedule-pending-instructions ,seg)
321     (setf (segment-run-scheduler ,seg) nil))
322     ,@body
323     (setf (segment-run-scheduler ,seg) ,var))))
324    
325 wlott 1.17 (defmacro note-dependencies ((segment inst) &body body)
326     (ext:once-only ((segment segment) (inst inst))
327     `(macrolet ((reads (loc) `(note-read-dependency ,',segment ,',inst ,loc))
328     (writes (loc &rest keys)
329     `(note-write-dependency ,',segment ,',inst ,loc ,@keys)))
330     ,@body)))
331    
332     (defun note-read-dependency (segment inst read)
333 dtc 1.27 (multiple-value-bind (loc-num size)
334     (c:location-number read)
335 rtoy 1.37 #+debug (format *trace-output* (intl:gettext "~&~S reads ~S[~D for ~D]~%")
336 dtc 1.27 inst read loc-num size)
337     (when loc-num
338     ;; Iterate over all the locations for this TN.
339     (do ((index loc-num (1+ index))
340     (end-loc (+ loc-num (or size 1))))
341     ((>= index end-loc))
342     (declare (type (mod 2048) index end-loc))
343     (let ((writers (svref (segment-writers segment) index)))
344     (when writers
345     ;; The inst that wrote the value we want to read must have
346     ;; completed.
347     (let ((writer (car writers)))
348     (sset-adjoin writer (inst-read-dependencies inst))
349     (sset-adjoin inst (inst-read-dependents writer))
350     (sset-delete writer (segment-emittable-insts-sset segment))
351     ;; And it must have been completed *after* all other
352     ;; writes to that location. Actually, that isn't quite
353     ;; true. Each of the earlier writes could be done
354     ;; either before this last write, or after the read, but
355     ;; we have no way of representing that.
356     (dolist (other-writer (cdr writers))
357     (sset-adjoin other-writer (inst-write-dependencies writer))
358     (sset-adjoin writer (inst-write-dependents other-writer))
359     (sset-delete other-writer
360     (segment-emittable-insts-sset segment))))
361     ;; And we don't need to remember about earlier writes any
362     ;; more. Shortening the writers list means that we won't
363     ;; bother generating as many explicit arcs in the graph.
364     (setf (cdr writers) nil)))
365     (push inst (svref (segment-readers segment) index)))))
366 wlott 1.17 (ext:undefined-value))
367    
368     (defun note-write-dependency (segment inst write &key partially)
369 dtc 1.27 (multiple-value-bind (loc-num size)
370     (c:location-number write)
371 rtoy 1.37 #+debug (format *trace-output* (intl:gettext "~&~S writes ~S[~D for ~D]~%")
372 dtc 1.27 inst write loc-num size)
373     (when loc-num
374     ;; Iterate over all the locations for this TN.
375     (do ((index loc-num (1+ index))
376     (end-loc (+ loc-num (or size 1))))
377     ((>= index end-loc))
378     (declare (type (mod 2048) index end-loc))
379     ;; All previous reads of this location must have completed.
380     (dolist (prev-inst (svref (segment-readers segment) index))
381     (unless (eq prev-inst inst)
382     (sset-adjoin prev-inst (inst-write-dependencies inst))
383     (sset-adjoin inst (inst-write-dependents prev-inst))
384     (sset-delete prev-inst (segment-emittable-insts-sset segment))))
385     (when partially
386     ;; All previous writes to the location must have completed.
387     (dolist (prev-inst (svref (segment-writers segment) index))
388     (sset-adjoin prev-inst (inst-write-dependencies inst))
389     (sset-adjoin inst (inst-write-dependents prev-inst))
390     (sset-delete prev-inst (segment-emittable-insts-sset segment)))
391     ;; And we can forget about remembering them, because
392     ;; depending on us is as good as depending on them.
393     (setf (svref (segment-writers segment) index) nil))
394     (push inst (svref (segment-writers segment) index)))))
395 wlott 1.17 (ext:undefined-value))
396    
397 wlott 1.1 ;;; QUEUE-INST -- internal.
398     ;;;
399     ;;; This routine is called by due to uses of the INST macro when the scheduler
400 wlott 1.17 ;;; is turned on. The change to the dependency graph has already been
401     ;;; computed, so we just have to check to see if the basic block is terminated.
402 wlott 1.1 ;;;
403 wlott 1.17 (defun queue-inst (segment inst)
404 rtoy 1.37 #+debug (format *trace-output* (intl:gettext "~&Queuing ~S~%") inst)
405 wlott 1.24 #+debug
406 rtoy 1.37 (format *trace-output* (intl:gettext " reads ~S~% writes ~S~%")
407 wlott 1.24 (ext:collect ((reads))
408     (do-elements (read (inst-read-dependencies inst))
409     (reads read))
410     (reads))
411     (ext:collect ((writes))
412     (do-elements (write (inst-write-dependencies inst))
413     (writes write))
414     (writes)))
415 wlott 1.1 (assert (segment-run-scheduler segment))
416 wlott 1.17 (let ((countdown (segment-branch-countdown segment)))
417 wlott 1.19 (when countdown
418 wlott 1.21 (decf countdown)
419     (assert (not (instruction-attributep (inst-attributes inst)
420     variable-length))))
421 wlott 1.17 (cond ((instruction-attributep (inst-attributes inst) branch)
422     (unless countdown
423     (setf countdown (inst-delay inst)))
424     (push (cons countdown inst)
425     (segment-queued-branches segment)))
426     (t
427     (sset-adjoin inst (segment-emittable-insts-sset segment))))
428     (when countdown
429 wlott 1.19 (setf (segment-branch-countdown segment) countdown)
430     (when (zerop countdown)
431     (schedule-pending-instructions segment))))
432 wlott 1.1 (ext:undefined-value))
433    
434     ;;; SCHEDULE-PENDING-INSTRUCTIONS -- internal.
435     ;;;
436     ;;; Emit all the pending instructions, and reset any state. This is called
437     ;;; whenever we hit a label (i.e. an entry point of some kind) and when the
438     ;;; user turns the scheduler off (otherwise, the queued instructions would
439     ;;; sit there until the scheduler was turned back on, and emitted in the
440     ;;; wrong place).
441     ;;;
442     (defun schedule-pending-instructions (segment)
443     (assert (segment-run-scheduler segment))
444     ;;
445     ;; Quick blow-out if nothing to do.
446 wlott 1.17 (when (and (sset-empty (segment-emittable-insts-sset segment))
447     (null (segment-queued-branches segment)))
448 wlott 1.1 (return-from schedule-pending-instructions
449     (ext:undefined-value)))
450     ;;
451 wlott 1.24 #+debug
452 rtoy 1.37 (format *trace-output* (intl:gettext "~&Scheduling pending instructions...~%"))
453 wlott 1.24 ;;
454 wlott 1.15 ;; Note that any values live at the end of the block have to be computed
455     ;; last.
456 wlott 1.17 (let ((emittable-insts (segment-emittable-insts-sset segment))
457     (writers (segment-writers segment)))
458     (dotimes (index (length writers))
459     (let* ((writer (svref writers index))
460     (inst (car writer))
461     (overwritten (cdr writer)))
462     (when writer
463     (when overwritten
464     (let ((write-dependencies (inst-write-dependencies inst)))
465     (dolist (other-inst overwritten)
466     (sset-adjoin inst (inst-write-dependents other-inst))
467     (sset-adjoin other-inst write-dependencies)
468     (sset-delete other-inst emittable-insts))))
469     ;; If the value is live at the end of the block, we can't flush it.
470     (setf (instruction-attributep (inst-attributes inst) flushable)
471     nil)))))
472 wlott 1.15 ;;
473 wlott 1.1 ;; Grovel through the entire graph in the forward direction finding all
474     ;; the leaf instructions.
475     (labels ((grovel-inst (inst)
476 wlott 1.17 (let ((max 0))
477     (do-elements (dep (inst-write-dependencies inst))
478 wlott 1.1 (let ((dep-depth (or (inst-depth dep) (grovel-inst dep))))
479     (when (> dep-depth max)
480     (setf max dep-depth))))
481 wlott 1.17 (do-elements (dep (inst-read-dependencies inst))
482 wlott 1.1 (let ((dep-depth
483     (+ (or (inst-depth dep) (grovel-inst dep))
484     (inst-delay dep))))
485     (when (> dep-depth max)
486     (setf max dep-depth))))
487 wlott 1.17 (cond ((and (sset-empty (inst-read-dependents inst))
488 wlott 1.1 (instruction-attributep (inst-attributes inst)
489 wlott 1.15 flushable))
490 hallgren 1.8 #+debug
491 rtoy 1.37 (format *trace-output* (intl:gettext "Flushing ~S~%") inst)
492 wlott 1.1 (setf (inst-emitter inst) nil)
493     (setf (inst-depth inst) max))
494     (t
495 wlott 1.17 (setf (inst-depth inst) max))))))
496     (let ((emittable-insts nil)
497 wlott 1.1 (delayed nil))
498 wlott 1.17 (do-elements (inst (segment-emittable-insts-sset segment))
499 wlott 1.1 (grovel-inst inst)
500     (if (zerop (inst-delay inst))
501 wlott 1.17 (push inst emittable-insts)
502 wlott 1.1 (setf delayed
503     (add-to-nth-list delayed inst (1- (inst-delay inst))))))
504 wlott 1.17 (setf (segment-emittable-insts-queue segment)
505     (sort emittable-insts #'> :key #'inst-depth))
506 wlott 1.13 (setf (segment-delayed segment) delayed))
507     (dolist (branch (segment-queued-branches segment))
508     (grovel-inst (cdr branch))))
509 hallgren 1.8 #+debug
510 rtoy 1.37 (format *trace-output* (intl:gettext "Queued branches: ~S~%")
511 wlott 1.1 (segment-queued-branches segment))
512 hallgren 1.8 #+debug
513 rtoy 1.37 (format *trace-output* (intl:gettext "Initially emittable: ~S~%")
514 wlott 1.17 (segment-emittable-insts-queue segment))
515 hallgren 1.8 #+debug
516 rtoy 1.37 (format *trace-output* (intl:gettext "Initially delayed: ~S~%")
517 wlott 1.1 (segment-delayed segment))
518     ;;
519     ;; Accumulate the results in reverse order. Well, actually, this list will
520     ;; be in forward order, because we are generating the reverse order in
521     ;; reverse.
522     (let ((results nil))
523     ;;
524     ;; Schedule all the branches in their exact locations.
525 wlott 1.19 (let ((insts-from-end (segment-branch-countdown segment)))
526 wlott 1.1 (dolist (branch (segment-queued-branches segment))
527 hallgren 1.9 (let ((inst (cdr branch)))
528 wlott 1.14 (dotimes (i (- (car branch) insts-from-end))
529 wlott 1.24 ;; Each time through this loop we need to emit another instruction.
530     ;; First, we check to see if there is any instruction that must
531     ;; be emitted before (i.e. must come after) the branch inst. If
532     ;; so, emit it. Otherwise, just pick one of the emittable insts.
533     ;; If there is nothing to do, the emit a nop.
534     ;; ### Note: despite the fact that this is a loop, it really won't
535     ;; work for repetitions other then zero and one. For example, if
536     ;; the branch has two dependents and one of them dpends on the
537     ;; other, then the stuff that grabs a dependent could easily
538     ;; grab the wrong one. But I don't feel like fixing this because
539     ;; it doesn't matter for any of the architectures we are using
540     ;; or plan on using.
541 wlott 1.14 (flet ((maybe-schedule-dependent (dependents)
542 wlott 1.17 (do-elements (inst dependents)
543 wlott 1.24 ;; If do-elements enters the body, then there is a
544     ;; dependent. Emit it.
545 wlott 1.17 (note-resolved-dependencies segment inst)
546 wlott 1.24 ;; Remove it from the emittable insts.
547 wlott 1.17 (setf (segment-emittable-insts-queue segment)
548     (delete inst
549     (segment-emittable-insts-queue segment)
550     :test #'eq))
551 wlott 1.24 ;; And if it was delayed, removed it from the delayed
552     ;; list. This can happen if there is a load in a
553     ;; branch delay slot.
554     (block scan-delayed
555     (do ((delayed (segment-delayed segment)
556     (cdr delayed)))
557     ((null delayed))
558     (do ((prev nil cons)
559     (cons (car delayed) (cdr cons)))
560     ((null cons))
561     (when (eq (car cons) inst)
562     (if prev
563     (setf (cdr prev) (cdr cons))
564     (setf (car delayed) (cdr cons)))
565     (return-from scan-delayed nil)))))
566     ;; And return it.
567 wlott 1.17 (return inst))))
568 wlott 1.24 (let ((fill (or (maybe-schedule-dependent
569     (inst-read-dependents inst))
570     (maybe-schedule-dependent
571     (inst-write-dependents inst))
572     (schedule-one-inst segment t)
573     :nop)))
574     #+debug
575 rtoy 1.37 (format *trace-output* (intl:gettext "Filling branch delay slot with ~S~%")
576 wlott 1.24 fill)
577     (push fill results)))
578 wlott 1.14 (advance-one-inst segment)
579     (incf insts-from-end))
580 hallgren 1.9 (note-resolved-dependencies segment inst)
581 wlott 1.14 (push inst results)
582     #+debug
583 rtoy 1.37 (format *trace-output* (intl:gettext "Emitting ~S~%") inst)
584 wlott 1.14 (advance-one-inst segment))))
585 wlott 1.1 ;;
586     ;; Keep scheduling stuff until we run out.
587     (loop
588 wlott 1.21 (let ((inst (schedule-one-inst segment nil)))
589 wlott 1.1 (unless inst
590     (return))
591     (push inst results)
592     (advance-one-inst segment)))
593     ;;
594     ;; Now call the emitters, but turn the scheduler off for the duration.
595     (setf (segment-run-scheduler segment) nil)
596     (dolist (inst results)
597     (if (eq inst :nop)
598 hallgren 1.10 (c:emit-nop segment)
599 wlott 1.1 (funcall (inst-emitter inst) segment)))
600     (setf (segment-run-scheduler segment) t))
601     ;;
602     ;; Clear out any residue left over.
603 wlott 1.17 (setf (segment-inst-number segment) 0)
604 wlott 1.1 (setf (segment-queued-branches segment) nil)
605     (setf (segment-branch-countdown segment) nil)
606 wlott 1.17 (setf (segment-emittable-insts-sset segment) (make-sset))
607     (fill (segment-readers segment) nil)
608     (fill (segment-writers segment) nil)
609 wlott 1.1 ;;
610     ;; That's all folks.
611     (ext:undefined-value))
612    
613     ;;; ADD-TO-NTH-LIST -- internal.
614     ;;;
615     ;;; Utility for maintaining the segment-delayed list. We cdr down list
616     ;;; n times (extending it if necessary) and then push thing on into the car
617     ;;; of that cons cell.
618     ;;;
619     (defun add-to-nth-list (list thing n)
620     (do ((cell (or list (setf list (list nil)))
621     (or (cdr cell) (setf (cdr cell) (list nil))))
622     (i n (1- i)))
623     ((zerop i)
624     (push thing (car cell))
625     list)))
626    
627     ;;; SCHEDULE-ONE-INST -- internal.
628     ;;;
629     ;;; Find the next instruction to schedule and return it after updating
630     ;;; any dependency information. If we can't do anything useful right
631     ;;; now, but there is more work to be done, return :NOP to indicate that
632     ;;; a nop must be emitted. If we are all done, return NIL.
633     ;;;
634 wlott 1.21 (defun schedule-one-inst (segment delay-slot-p)
635     (do ((prev nil remaining)
636     (remaining (segment-emittable-insts-queue segment) (cdr remaining)))
637     ((null remaining))
638     (let ((inst (car remaining)))
639     (unless (and delay-slot-p
640     (instruction-attributep (inst-attributes inst)
641     variable-length))
642     ;; We've got us a live one here. Go for it.
643     #+debug
644 rtoy 1.37 (format *Trace-output* (intl:gettext "Emitting ~S~%") inst)
645 wlott 1.21 ;; Delete it from the list of insts.
646     (if prev
647     (setf (cdr prev) (cdr remaining))
648     (setf (segment-emittable-insts-queue segment)
649     (cdr remaining)))
650     ;; Note that this inst has been emitted.
651     (note-resolved-dependencies segment inst)
652     ;; And return.
653     (return-from schedule-one-inst
654     ;; Are we wanting to flush this instruction?
655     (if (inst-emitter inst)
656     ;; Nope, it's still a go. So return it.
657     inst
658     ;; Yes, so pick a new one. We have to start over,
659     ;; because note-resolved-dependencies might have
660     ;; changed the emittable-insts-queue.
661     (schedule-one-inst segment delay-slot-p))))))
662     ;; Nothing to do, so make something up.
663     (cond ((segment-delayed segment)
664     ;; No emittable instructions, but we have more work to do. Emit
665     ;; a NOP to fill in a delay slot.
666 rtoy 1.37 #+debug (format *trace-output* (intl:gettext "Emitting a NOP.~%"))
667 wlott 1.21 :nop)
668     (t
669     ;; All done.
670     nil)))
671 hallgren 1.9
672     ;;; NOTE-RESOLVED-DEPENDENCIES -- internal.
673     ;;;
674     ;;; This function is called whenever an instruction has been scheduled, and we
675     ;;; want to know what possibilities that opens up. So look at all the
676     ;;; instructions that this one depends on, and remove this instruction from
677     ;;; their dependents list. If we were the last dependent, then that
678     ;;; dependency can be emitted now.
679     ;;;
680     (defun note-resolved-dependencies (segment inst)
681 wlott 1.17 (assert (sset-empty (inst-read-dependents inst)))
682     (assert (sset-empty (inst-write-dependents inst)))
683     (do-elements (dep (inst-write-dependencies inst))
684 hallgren 1.9 ;; These are the instructions who have to be completed before our
685     ;; write fires. Doesn't matter how far before, just before.
686     (let ((dependents (inst-write-dependents dep)))
687 wlott 1.17 (sset-delete inst dependents)
688     (when (and (sset-empty dependents)
689     (sset-empty (inst-read-dependents dep)))
690 hallgren 1.9 (insert-emittable-inst segment dep))))
691 wlott 1.17 (do-elements (dep (inst-read-dependencies inst))
692 hallgren 1.9 ;; These are the instructions who write values we read. If there
693     ;; is no delay, then just remove us from the dependent list.
694     ;; Otherwise, record the fact that in n cycles, we should be
695     ;; removed.
696     (if (zerop (inst-delay dep))
697     (let ((dependents (inst-read-dependents dep)))
698 wlott 1.17 (sset-delete inst dependents)
699     (when (and (sset-empty dependents)
700     (sset-empty (inst-write-dependents dep)))
701 hallgren 1.9 (insert-emittable-inst segment dep)))
702     (setf (segment-delayed segment)
703     (add-to-nth-list (segment-delayed segment)
704     (cons dep inst)
705     (inst-delay dep)))))
706     (ext:undefined-value))
707 wlott 1.1
708     ;;; ADVANCE-ONE-INST -- internal.
709     ;;;
710     ;;; Process the next entry in segment-delayed. This is called whenever anyone
711     ;;; emits an instruction.
712     ;;;
713     (defun advance-one-inst (segment)
714     (let ((delayed-stuff (pop (segment-delayed segment))))
715     (dolist (stuff delayed-stuff)
716     (if (consp stuff)
717     (let* ((dependency (car stuff))
718     (dependent (cdr stuff))
719     (dependents (inst-read-dependents dependency)))
720 wlott 1.17 (sset-delete dependent dependents)
721     (when (and (sset-empty dependents)
722     (sset-empty (inst-write-dependents dependency)))
723 wlott 1.1 (insert-emittable-inst segment dependency)))
724     (insert-emittable-inst segment stuff)))))
725    
726     ;;; INSERT-EMITTABLE-INST -- internal.
727     ;;;
728 wlott 1.17 ;;; Note that inst is emittable by sticking it in the SEGMENT-EMITTABLE-INSTS-
729     ;;; QUEUE list. We keep the emittable-insts sorted with the largest ``depths''
730 wlott 1.14 ;;; first. Except that if INST is a branch, don't bother. It will be handled
731     ;;; correctly by the branch emitting code in SCHEDULE-PENDING-INSTRUCTIONS.
732 wlott 1.1 ;;;
733     (defun insert-emittable-inst (segment inst)
734 wlott 1.14 (unless (instruction-attributep (inst-attributes inst) branch)
735     #+debug
736 rtoy 1.37 (format *Trace-output* (intl:gettext "Now emittable: ~S~%") inst)
737 wlott 1.14 (do ((my-depth (inst-depth inst))
738 wlott 1.17 (remaining (segment-emittable-insts-queue segment) (cdr remaining))
739 wlott 1.14 (prev nil remaining))
740     ((or (null remaining) (> my-depth (inst-depth (car remaining))))
741     (if prev
742     (setf (cdr prev) (cons inst remaining))
743 wlott 1.17 (setf (segment-emittable-insts-queue segment)
744     (cons inst remaining))))))
745 wlott 1.14 (ext:undefined-value))
746 wlott 1.1
747    
748     ;;;; Structure used during output emission.
749    
750     ;;; ANNOTATION -- Common supertype for all the different kinds of annotations.
751     ;;;
752     (defstruct (annotation
753     (:constructor nil))
754     ;;
755     ;; Where in the raw output stream was this annotation emitted.
756     (index 0 :type index)
757     ;;
758     ;; What position does that correspond to.
759     (posn nil :type (or index null)))
760    
761     ;;; LABEL -- Doesn't need any additional information beyond what is in the
762     ;;; annotation structure.
763     ;;;
764     (defstruct (label
765     (:include annotation)
766     (:constructor gen-label ())
767     (:print-function %print-label))
768     )
769     ;;;
770     (defun %print-label (label stream depth)
771     (declare (ignore depth))
772     (if (or *print-escape* *print-readably*)
773     (print-unreadable-object (label stream :type t)
774     (prin1 (c:label-id label) stream))
775     (format stream "L~D" (c:label-id label))))
776    
777     ;;; ALIGNMENT-NOTE -- A constraint on how the output stream must be aligned.
778     ;;;
779     (defstruct (alignment-note
780     (:include annotation)
781     (:conc-name alignment-)
782     (:predicate alignment-p)
783 ram 1.26 (:constructor make-alignment (bits size fill-byte)))
784 wlott 1.1 ;;
785     ;; The minimum number of low-order bits that must be zero.
786     (bits 0 :type alignment)
787     ;;
788     ;; The amount of filler we are assuming this alignment op will take.
789 ram 1.26 (size 0 :type (integer 0 #.(1- (ash 1 max-alignment))))
790     ;;
791     ;; The byte used as filling.
792     (fill-byte 0 :type (or assembly-unit (signed-byte #.assembly-unit-bits))))
793 wlott 1.1
794     ;;; BACK-PATCH -- a reference to someplace that needs to be back-patched when
795     ;;; we actually know what label positions, etc. are.
796     ;;;
797     (defstruct (back-patch
798     (:include annotation)
799     (:constructor make-back-patch (size function)))
800     ;;
801     ;; The area effected by this back-patch.
802     (size 0 :type index)
803     ;;
804     ;; The function to use to generate the real data
805     (function nil :type function))
806    
807     ;;; CHOOSER -- Similar to a back-patch, but also an indication that the amount
808     ;;; of stuff output depends on label-positions, etc. Back-patches can't change
809     ;;; their mind about how much stuff to emit, but choosers can.
810     ;;;
811     (defstruct (chooser
812     (:include annotation)
813     (:constructor make-chooser
814     (size alignment maybe-shrink worst-case-fun)))
815     ;;
816     ;; The worst case size for this chooser. There is this much space allocated
817     ;; in the output buffer.
818     (size 0 :type index)
819     ;;
820     ;; The worst case alignment this chooser is guarenteed to preserve.
821     (alignment 0 :type alignment)
822     ;;
823     ;; The function to call to determine of we can use a shorter sequence. It
824     ;; returns NIL if nothing shorter can be used, or emits that sequence and
825     ;; returns T.
826     (maybe-shrink nil :type function)
827     ;;
828     ;; The function to call to generate the worst case sequence. This is used
829     ;; when nothing else can be condensed.
830     (worst-case-fun nil :type function))
831    
832     ;;; FILLER -- Used internally when we figure out a chooser or alignment doesn't
833     ;;; really need as much space as we initially gave it.
834     ;;;
835     (defstruct (filler
836     (:include annotation)
837     (:constructor make-filler (bytes)))
838     ;;
839     ;; The number of bytes of filler here.
840     (bytes 0 :type index))
841    
842    
843    
844     ;;;; Output buffer utility functions.
845    
846     ;;; A list of all the output-blocks we have allocated but aren't using.
847     ;;; We free-list them because allocation more is slow and the garbage collector
848     ;;; doesn't know about them, so it can't be slowed down by use keep ahold of
849     ;;; them.
850     ;;;
851     (defvar *available-output-blocks* nil)
852    
853     ;;; A list of all the output-blocks we have ever allocated. We don't really
854     ;;; need to keep tract of this if RELEASE-OUTPUT-BLOCK were always called,
855     ;;; but...
856     ;;;
857     (defvar *all-output-blocks* nil)
858    
859     ;;; NEW-OUTPUT-BLOCK -- internal.
860     ;;;
861     ;;; Return a new output block, allocating one if necessary.
862     ;;;
863     (defun new-output-block ()
864     (if *available-output-blocks*
865     (pop *available-output-blocks*)
866     (let ((block (system:allocate-system-memory output-block-size)))
867     (push block *all-output-blocks*)
868     block)))
869    
870     ;;; RELEASE-OUTPUT-BLOCK -- internal.
871     ;;;
872     ;;; Return block to the list of avaiable blocks.
873     ;;;
874     (defun release-output-block (block)
875     (push block *available-output-blocks*))
876    
877     ;;; FORGET-OUTPUT-BLOCKS -- internal.
878     ;;;
879     ;;; We call this whenever a core starts up, because system-memory isn't
880     ;;; saves with the core. If we didn't, we would find our hands full of
881     ;;; bogus SAPs, which would make all sorts of things unhappy.
882     ;;;
883     (defun forget-output-blocks ()
884 wlott 1.5 (setf *all-output-blocks* nil)
885 wlott 1.1 (setf *available-output-blocks* nil))
886     ;;;
887     (pushnew 'forget-output-blocks ext:*after-save-initializations*)
888    
889    
890    
891     ;;;; Output functions.
892    
893     ;;; FIND-NEW-FILL-POINTER -- internal.
894     ;;;
895     ;;; Find us a new fill pointer for the current index in segment. Allocate
896     ;;; any additional storage as necessary.
897     ;;;
898     (defun find-new-fill-pointer (segment)
899     (declare (type segment segment))
900     (let* ((index (segment-current-index segment))
901     (blocks (segment-output-blocks segment))
902     (num-blocks (length blocks)))
903     (multiple-value-bind
904     (block-num offset)
905     (truncate index output-block-size)
906     (when (>= block-num num-blocks)
907 wlott 1.5 (setf blocks
908     (adjust-array blocks (+ block-num 3) :initial-element nil))
909 wlott 1.1 (setf (segment-output-blocks segment) blocks))
910     (let ((block (or (aref blocks block-num)
911     (setf (aref blocks block-num) (new-output-block)))))
912     (setf (segment-block-end segment)
913     (system:sap+ block output-block-size))
914     (setf (segment-fill-pointer segment) (system:sap+ block offset))))))
915    
916     ;;; EMIT-BYTE -- interface.
917     ;;;
918     ;;; Emit the supplied BYTE to SEGMENT, growing it if necessary.
919     ;;;
920     (declaim (inline emit-byte))
921     (defun emit-byte (segment byte)
922 rtoy 1.36 "Emit BYTE to SEGMENT."
923 wlott 1.1 (declare (type segment segment)
924     (type (or assembly-unit (signed-byte #.assembly-unit-bits)) byte))
925     (let* ((orig-ptr (segment-fill-pointer segment))
926     (ptr (if (system:sap= orig-ptr (segment-block-end segment))
927     (find-new-fill-pointer segment)
928     orig-ptr)))
929     (setf (system:sap-ref-8 ptr 0) (ldb (byte assembly-unit-bits 0) byte))
930     (setf (segment-fill-pointer segment) (system:sap+ ptr 1)))
931     (incf (segment-current-posn segment))
932     (incf (segment-current-index segment))
933     (ext:undefined-value))
934    
935     ;;; EMIT-SKIP -- interface.
936     ;;;
937 ram 1.26 (defun emit-skip (segment amount &optional (fill-byte 0))
938 rtoy 1.36 "Output AMOUNT zeros (in bytes) to SEGMENT."
939 wlott 1.1 (declare (type segment segment)
940     (type index amount))
941     (dotimes (i amount)
942 ram 1.26 (emit-byte segment fill-byte))
943 wlott 1.1 (ext:undefined-value))
944    
945     ;;; EMIT-ANNOTATION -- internal.
946     ;;;
947     ;;; Used to handle the common parts of annotation emision. We just
948     ;;; assign the posn and index of the note and tack it on to the end
949     ;;; of the segment's annotations list.
950     ;;;
951     (defun emit-annotation (segment note)
952     (declare (type segment segment)
953     (type annotation note))
954     (when (annotation-posn note)
955 rtoy 1.37 (error (intl:gettext "Attempt to emit ~S for the second time.") note))
956 wlott 1.1 (setf (annotation-posn note) (segment-current-posn segment))
957     (setf (annotation-index note) (segment-current-index segment))
958     (let ((last (segment-last-annotation segment))
959     (new (list note)))
960     (setf (segment-last-annotation segment)
961     (if last
962     (setf (cdr last) new)
963     (setf (segment-annotations segment) new))))
964     (ext:undefined-value))
965    
966     ;;; EMIT-BACK-PATCH -- interface.
967     ;;;
968     (defun emit-back-patch (segment size function)
969 rtoy 1.36 "Note that the instruction stream has to be back-patched when label positions
970 wlott 1.1 are finally known. SIZE bytes are reserved in SEGMENT, and function will
971     be called with two arguments: the segment and the position. The function
972     should look at the position and the position of any labels it wants to
973     and emit the correct sequence. (And it better be the same size as SIZE).
974     SIZE can be zero, which is useful if you just want to find out where things
975     ended up."
976     (emit-annotation segment (make-back-patch size function))
977     (emit-skip segment size))
978    
979     ;;; EMIT-CHOOSER -- interface.
980     ;;;
981     (defun emit-chooser (segment size alignment maybe-shrink worst-case-fun)
982 rtoy 1.36 "Note that the instruction stream here depends on the actual positions of
983 wlott 1.1 various labels, so can't be output until label positions are known. Space
984     is made in SEGMENT for at least SIZE bytes. When all output has been
985     generated, the MAYBE-SHRINK functions for all choosers are called with
986     three arguments: the segment, the position, and a magic value. The MAYBE-
987     SHRINK decides if it can use a shorter sequence, and if so, emits that
988     sequence to the segment and returns T. If it can't do better than the
989     worst case, it should return NIL (without emitting anything). When calling
990     LABEL-POSITION, it should pass it the position and the magic-value it was
991     passed so that LABEL-POSITION can return the correct result. If the chooser
992     never decides to use a shorter sequence, the WORST-CASE-FUN will be called,
993     just like a BACK-PATCH. (See EMIT-BACK-PATCH.)"
994     (declare (type segment segment) (type index size) (type alignment alignment)
995     (type function maybe-shrink worst-case-fun))
996     (let ((chooser (make-chooser size alignment maybe-shrink worst-case-fun)))
997     (emit-annotation segment chooser)
998     (emit-skip segment size)
999     (adjust-alignment-after-chooser segment chooser)))
1000    
1001     ;;; ADJUST-ALIGNMENT-AFTER-CHOOSER -- internal.
1002     ;;;
1003     ;;; Called in EMIT-CHOOSER and COMPRESS-SEGMENT in order to recompute the
1004     ;;; current alignment information in light of this chooser. If the alignment
1005     ;;; guarenteed byte the chooser is less then the segments current alignment,
1006     ;;; we have to adjust the segments notion of the current alignment.
1007     ;;;
1008     ;;; The hard part is recomputing the sync posn, because it's not just the
1009     ;;; choosers posn. Consider a chooser that emits either one or three words.
1010     ;;; It preserves 8-byte (3 bit) alignments, because the difference between
1011     ;;; the two choices is 8 bytes.
1012     ;;;
1013     (defun adjust-alignment-after-chooser (segment chooser)
1014     (declare (type segment segment) (type chooser chooser))
1015     (let ((alignment (chooser-alignment chooser))
1016     (seg-alignment (segment-alignment segment)))
1017     (when (< alignment seg-alignment)
1018     ;; The chooser might change the alignment of the output. So we have
1019     ;; to figure out what the worst case alignment could be.
1020     (setf (segment-alignment segment) alignment)
1021     (let* ((posn (chooser-posn chooser))
1022     (sync-posn (segment-sync-posn segment))
1023     (offset (- posn sync-posn))
1024     (delta (logand offset (1- (ash 1 alignment)))))
1025     (setf (segment-sync-posn segment) (- posn delta)))))
1026     (ext:undefined-value))
1027    
1028     ;;; EMIT-FILLER -- internal.
1029     ;;;
1030     ;;; Used internally whenever a chooser or alignment decides it doesn't need
1031     ;;; as much space as it originally though.
1032     ;;;
1033     (defun emit-filler (segment bytes)
1034     (let ((last (segment-last-annotation segment)))
1035     (cond ((and last (filler-p (car last)))
1036     (incf (filler-bytes (car last)) bytes))
1037     (t
1038     (emit-annotation segment (make-filler bytes)))))
1039     (incf (segment-current-index segment) bytes)
1040     (setf (segment-fill-pointer segment) (system:int-sap 0))
1041     (setf (segment-block-end segment) (system:int-sap 0))
1042     (ext:undefined-value))
1043    
1044 wlott 1.2 ;;; %EMIT-LABEL -- internal.
1045 wlott 1.1 ;;;
1046     ;;; EMIT-LABEL (the interface) basically just expands into this, supplying
1047 wlott 1.2 ;;; the segment and vop.
1048 wlott 1.1 ;;;
1049     (defun %emit-label (segment vop label)
1050     (when (segment-run-scheduler segment)
1051     (schedule-pending-instructions segment))
1052 wlott 1.2 (let ((postits (segment-postits segment)))
1053     (setf (segment-postits segment) nil)
1054     (dolist (postit postits)
1055     (emit-back-patch segment 0 postit)))
1056 wlott 1.1 (let ((hook (segment-inst-hook segment)))
1057     (when hook
1058     (funcall hook segment vop :label label)))
1059     (emit-annotation segment label))
1060    
1061     ;;; EMIT-ALIGNMENT -- internal.
1062     ;;;
1063     ;;; Called by the ALIGN macro to emit an alignment note. We check to see
1064     ;;; if we can guarentee the alignment restriction by just outputing a fixed
1065     ;;; number of bytes. If so, we do so. Otherwise, we create and emit
1066     ;;; an alignment note.
1067     ;;;
1068 ram 1.26 (defun emit-alignment (segment vop bits &optional (fill-byte 0))
1069 wlott 1.1 (when (segment-run-scheduler segment)
1070     (schedule-pending-instructions segment))
1071     (let ((hook (segment-inst-hook segment)))
1072     (when hook
1073     (funcall hook segment vop :align bits)))
1074     (let ((alignment (segment-alignment segment))
1075     (offset (- (segment-current-posn segment)
1076     (segment-sync-posn segment))))
1077     (cond ((> bits alignment)
1078     ;; We need more bits of alignment. First emit enough noise
1079     ;; to get back in sync with alignment, and then emit an alignment
1080     ;; note to cover the rest.
1081     (let ((slop (logand offset (1- (ash 1 alignment)))))
1082     (unless (zerop slop)
1083 ram 1.26 (emit-skip segment (- (ash 1 alignment) slop) fill-byte)))
1084 wlott 1.1 (let ((size (logand (1- (ash 1 bits))
1085     (lognot (1- (ash 1 alignment))))))
1086     (assert (> size 0))
1087 ram 1.26 (emit-annotation segment (make-alignment bits size fill-byte))
1088     (emit-skip segment size fill-byte))
1089 wlott 1.1 (setf (segment-alignment segment) bits)
1090     (setf (segment-sync-posn segment) (segment-current-posn segment)))
1091     (t
1092     ;; The last alignment was more restrictive then this one.
1093     ;; So we can just figure out how much noise to emit assuming
1094     ;; the last alignment was met.
1095     (let* ((mask (1- (ash 1 bits)))
1096     (new-offset (logand (+ offset mask) (lognot mask))))
1097 ram 1.26 (emit-skip segment (- new-offset offset) fill-byte))
1098 wlott 1.1 ;; But we emit an alignment with size=0 so we can verify
1099     ;; that everything works.
1100 ram 1.26 (emit-annotation segment (make-alignment bits 0 fill-byte)))))
1101 wlott 1.1 (ext:undefined-value))
1102    
1103    
1104     ;;; FIND-ALIGNMENT -- internal.
1105     ;;;
1106     ;;; Used to find how ``aligned'' different offsets are. Returns the number
1107     ;;; of low-order 0 bits, up to MAX-ALIGNMENT.
1108     ;;;
1109     (defun find-alignment (offset)
1110     (dotimes (i max-alignment max-alignment)
1111     (when (logbitp i offset)
1112     (return i))))
1113    
1114 wlott 1.2 ;;; EMIT-POSTIT -- Internal.
1115     ;;;
1116     ;;; Emit a postit. The function will be called as a back-patch with the
1117     ;;; position the following instruction is finally emitted. Postits do not
1118     ;;; interfere at all with scheduling.
1119     ;;;
1120     (defun %emit-postit (segment function)
1121     (push function (segment-postits segment))
1122     (ext:undefined-value))
1123 wlott 1.1
1124 wlott 1.2
1125 wlott 1.1
1126     ;;;; Output compression/position assignment stuff
1127    
1128     ;;; COMPRESS-OUTPUT -- internal.
1129     ;;;
1130     ;;; Grovel though all the annotations looking for choosers. When we find
1131     ;;; a chooser, invoke the maybe-shrink function. If it returns T, it output
1132     ;;; some other byte sequence.
1133     ;;;
1134     (defun compress-output (segment)
1135     (dotimes (i 5) ; it better not take more than one or two passes.
1136     (let ((delta 0))
1137     (setf (segment-alignment segment) max-alignment)
1138     (setf (segment-sync-posn segment) 0)
1139     (do* ((prev nil)
1140     (remaining (segment-annotations segment) next)
1141     (next (cdr remaining) (cdr remaining)))
1142     ((null remaining))
1143     (let* ((note (car remaining))
1144     (posn (annotation-posn note)))
1145     (unless (zerop delta)
1146     (decf posn delta)
1147     (setf (annotation-posn note) posn))
1148     (cond
1149     ((chooser-p note)
1150     (setf (segment-current-index segment) (chooser-index note))
1151     (setf (segment-current-posn segment) posn)
1152     (setf (segment-fill-pointer segment) (system:int-sap 0))
1153     (setf (segment-block-end segment) (system:int-sap 0))
1154     (setf (segment-last-annotation segment) prev)
1155     (cond
1156     ((funcall (chooser-maybe-shrink note) segment posn delta)
1157     ;; It emitted some replacement.
1158     (let ((new-size (- (segment-current-index segment)
1159     (chooser-index note)))
1160     (old-size (chooser-size note)))
1161     (when (> new-size old-size)
1162 rtoy 1.37 (error (intl:gettext "~S emitted ~D bytes, but claimed it's max was ~D")
1163 wlott 1.1 note new-size old-size))
1164     (let ((additional-delta (- old-size new-size)))
1165     (when (< (find-alignment additional-delta)
1166     (chooser-alignment note))
1167 rtoy 1.37 (error (intl:gettext "~S shrunk by ~D bytes, but claimed that it ~
1168     preserve ~D bits of alignment.")
1169 wlott 1.1 note additional-delta (chooser-alignment note)))
1170     (incf delta additional-delta)
1171     (emit-filler segment additional-delta))
1172     (setf prev (segment-last-annotation segment))
1173     (if prev
1174     (setf (cdr prev) (cdr remaining))
1175     (setf (segment-annotations segment)
1176     (cdr remaining)))))
1177     (t
1178     ;; The chooser passed on shrinking. Make sure it didn't emit
1179     ;; anything.
1180     (unless (= (segment-current-index segment) (chooser-index note))
1181 rtoy 1.37 (error (intl:gettext "Chooser ~S passed, but not before emitting ~D bytes.")
1182 wlott 1.1 note
1183     (- (segment-current-index segment)
1184     (chooser-index note))))
1185     ;; Act like we just emitted this chooser.
1186     (let ((size (chooser-size note)))
1187     (incf (segment-current-index segment) size)
1188     (incf (segment-current-posn segment) size))
1189     ;; Adjust the alignment accordingly.
1190     (adjust-alignment-after-chooser segment note)
1191     ;; And keep this chooser for next time around.
1192     (setf prev remaining))))
1193     ((alignment-p note)
1194     (unless (zerop (alignment-size note))
1195     ;; Re-emit the alignment, letting it collapse if we know anything
1196     ;; more about the alignment guarentees of the segment.
1197     (let ((index (alignment-index note)))
1198     (setf (segment-current-index segment) index)
1199     (setf (segment-current-posn segment) posn)
1200     (setf (segment-fill-pointer segment) (system:int-sap 0))
1201     (setf (segment-block-end segment) (system:int-sap 0))
1202     (setf (segment-last-annotation segment) prev)
1203 ram 1.26 (emit-alignment segment nil (alignment-bits note)
1204     (alignment-fill-byte note))
1205 wlott 1.1 (let* ((new-index (segment-current-index segment))
1206     (size (- new-index index))
1207     (old-size (alignment-size note))
1208     (additional-delta (- old-size size)))
1209     (when (minusp additional-delta)
1210 rtoy 1.37 (error (intl:gettext "Alignment ~S needs more space now? It was ~D, ~
1211     and is ~D now.")
1212 wlott 1.1 note old-size size))
1213     (when (plusp additional-delta)
1214     (emit-filler segment additional-delta)
1215     (incf delta additional-delta)))
1216     (setf prev (segment-last-annotation segment))
1217     (if prev
1218     (setf (cdr prev) (cdr remaining))
1219     (setf (segment-annotations segment)
1220     (cdr remaining))))))
1221     (t
1222     (setf prev remaining)))))
1223     (when (zerop delta)
1224     (return))
1225     (decf (segment-final-posn segment) delta)))
1226     (ext:undefined-value))
1227    
1228     ;;; FINALIZE-POSITIONS -- internal.
1229     ;;;
1230     ;;; We have run all the choosers we can, so now we have to figure out exactly
1231     ;;; how much space each alignment note needs.
1232     ;;;
1233     (defun finalize-positions (segment)
1234     (let ((delta 0))
1235     (do* ((prev nil)
1236     (remaining (segment-annotations segment) next)
1237     (next (cdr remaining) (cdr remaining)))
1238     ((null remaining))
1239     (let* ((note (car remaining))
1240     (posn (- (annotation-posn note) delta)))
1241     (cond
1242     ((alignment-p note)
1243     (let* ((bits (alignment-bits note))
1244     (mask (1- (ash 1 bits)))
1245     (new-posn (logand (+ posn mask) (lognot mask)))
1246     (size (- new-posn posn))
1247     (old-size (alignment-size note))
1248     (additional-delta (- old-size size)))
1249     (assert (<= 0 size old-size))
1250     (unless (zerop additional-delta)
1251     (setf (segment-last-annotation segment) prev)
1252     (incf delta additional-delta)
1253     (setf (segment-current-index segment) (alignment-index note))
1254     (setf (segment-current-posn segment) posn)
1255     (emit-filler segment additional-delta)
1256     (setf prev (segment-last-annotation segment)))
1257     (if prev
1258     (setf (cdr prev) next)
1259     (setf (segment-annotations segment) next))))
1260     (t
1261     (setf (annotation-posn note) posn)
1262     (setf prev remaining)
1263     (setf next (cdr remaining))))))
1264     (unless (zerop delta)
1265     (decf (segment-final-posn segment) delta)))
1266     (ext:undefined-value))
1267    
1268     ;;; PROCESS-BACK-PATCHES -- internal.
1269     ;;;
1270     ;;; Grovel over segment, filling in any backpatches. If any choosers are left
1271     ;;; over, we need to emit their worst case varient.
1272     ;;;
1273     (defun process-back-patches (segment)
1274     (do* ((prev nil)
1275     (remaining (segment-annotations segment) next)
1276     (next (cdr remaining) (cdr remaining)))
1277     ((null remaining))
1278     (let ((note (car remaining)))
1279     (flet ((fill-in (function old-size)
1280     (let ((index (annotation-index note))
1281     (posn (annotation-posn note)))
1282     (setf (segment-current-index segment) index)
1283     (setf (segment-current-posn segment) posn)
1284     (setf (segment-fill-pointer segment) (system:int-sap 0))
1285     (setf (segment-block-end segment) (system:int-sap 0))
1286     (setf (segment-last-annotation segment) prev)
1287     (funcall function segment posn)
1288     (let ((new-size (- (segment-current-index segment) index)))
1289     (unless (= new-size old-size)
1290 rtoy 1.37 (error (intl:gettext "~S emitted ~D bytes, but claimed it's was ~D")
1291 wlott 1.1 note new-size old-size)))
1292 wlott 1.4 (let ((tail (segment-last-annotation segment)))
1293     (if tail
1294     (setf (cdr tail) next)
1295     (setf (segment-annotations segment) next)))
1296     (setf next (cdr prev)))))
1297 wlott 1.1 (cond ((back-patch-p note)
1298     (fill-in (back-patch-function note)
1299     (back-patch-size note)))
1300     ((chooser-p note)
1301     (fill-in (chooser-worst-case-fun note)
1302     (chooser-size note)))
1303     (t
1304     (setf prev remaining)))))))
1305    
1306    
1307     ;;;; Interface to the rest of the compiler.
1308    
1309 toy 1.30 ;;; Macro %%CURRENT-SEGMENT%% -- internal.
1310 wlott 1.1 ;;;
1311 toy 1.30 ;;; Returns the current segment while assembling. Use ASSEMBLE to
1312     ;;; change it.
1313     ;;;
1314     ;;; Using a macro to access the underlying special variable
1315     ;;; *CURRENT-SEGMENT* allows us to play scoping tricks in
1316     ;;; DEFINE-INSTRUCTION, to detect calls to the INST macro that aren't
1317     ;;; inside the scope of an ASSEMBLE.
1318 wlott 1.1 ;;;
1319 pw 1.29 (defvar *current-segment*)
1320 toy 1.30 (defmacro %%current-segment%% () '*current-segment*)
1321 wlott 1.1
1322 toy 1.30 ;;; Macro %%CURRENT-VOP%% -- internal.
1323 wlott 1.1 ;;;
1324 toy 1.30 ;;; Like %%CURRENT-SEGMENT%%, but returns the current vop. Used
1325     ;;; only to keep track of which vops emit which insts.
1326 wlott 1.1 ;;;
1327     (defvar *current-vop* nil)
1328 toy 1.30 (defmacro %%current-vop%% () '*current-vop*)
1329 wlott 1.1
1330     ;;; ASSEMBLE -- interface.
1331     ;;;
1332 toy 1.30 ;;; Performance optimization: we MACROLET %%CURRENT-SEGMENT%% to a
1333     ;;; local holding the segment so that uses of %%CURRENT-SEGMENT%%
1334     ;;; inside the body don't have to keep dereferencing the symbol. Given
1335     ;;; that ASSEMBLE is the only interface to *CURRENT-SEGMENT*, we don't
1336     ;;; have to worry about the special value becomming out of sync with
1337     ;;; the lexical value. Unless some bozo closes over it, but nobody
1338     ;;; does anything like that...
1339 wlott 1.3 (defmacro assemble ((&optional segment vop &key labels) &body body
1340     &environment env)
1341 rtoy 1.36 "Execute BODY (as a progn) with SEGMENT as the current segment."
1342 wlott 1.1 (flet ((label-name-p (thing)
1343     (and thing (symbolp thing))))
1344 wlott 1.3 (let* ((seg-var (gensym "SEGMENT-"))
1345     (vop-var (gensym "VOP-"))
1346     (visable-labels (remove-if-not #'label-name-p body))
1347     (inherited-labels
1348     (multiple-value-bind
1349     (expansion expanded)
1350     (macroexpand '..inherited-labels.. env)
1351     (if expanded expansion nil)))
1352     (new-labels (append labels
1353     (set-difference visable-labels
1354     inherited-labels)))
1355     (nested-labels (set-difference (append inherited-labels new-labels)
1356     visable-labels)))
1357     (when (intersection labels inherited-labels)
1358 rtoy 1.37 (error (intl:gettext "Duplicate nested labels: ~S")
1359 wlott 1.3 (intersection labels inherited-labels)))
1360 toy 1.30 `(let* ((,seg-var ,(or segment '(%%current-segment%%)))
1361     (,vop-var ,(or vop '(%%current-vop%%)))
1362 pw 1.29 ,@(when segment
1363     `((*current-segment* ,seg-var)))
1364     ,@(when vop
1365     `((*current-vop* ,vop-var)))
1366 wlott 1.1 ,@(mapcar #'(lambda (name)
1367     `(,name (gen-label)))
1368 wlott 1.3 new-labels))
1369 toy 1.30 (declare (ignorable ,vop-var ,seg-var))
1370     (macrolet ((%%current-segment%% () '*current-segment*)
1371     (%%current-vop%% () '*current-vop*))
1372     (symbol-macrolet (,@(when (or inherited-labels nested-labels)
1373 wlott 1.3 `((..inherited-labels.. ,nested-labels))))
1374 wlott 1.1 ,@(mapcar #'(lambda (form)
1375     (if (label-name-p form)
1376     `(emit-label ,form)
1377     form))
1378 toy 1.30 body)))))))
1379 wlott 1.1
1380     ;;; INST -- interface.
1381     ;;;
1382     (defmacro inst (&whole whole instruction &rest args &environment env)
1383 rtoy 1.36 "Emit the specified instruction to the current segment."
1384 wlott 1.1 (let ((inst (gethash (symbol-name instruction)
1385     (assem-params-instructions
1386     (c:backend-assembler-params c:*target-backend*)))))
1387     (cond ((null inst)
1388 rtoy 1.37 (error (intl:gettext "Unknown instruction: ~S") instruction))
1389 wlott 1.1 ((functionp inst)
1390     (funcall inst (cdr whole) env))
1391     (t
1392 toy 1.30 `(,inst (%%current-segment%%) (%%current-vop%%) ,@args)))))
1393 wlott 1.1
1394     ;;; EMIT-LABEL -- interface.
1395     ;;;
1396 toy 1.30 ;;; Note: The need to capture MACROLET bindings of %%CURRENT-SEGMENT%%
1397     ;;; and %%CURRENT-VOP%% prevents this from being an ordinary function
1398     ;;; (likewise for EMIT-POSTIT and ALIGN, below).
1399 wlott 1.1 (defmacro emit-label (label)
1400 rtoy 1.36 "Emit LABEL at this location in the current segment."
1401 toy 1.30 `(%emit-label (%%current-segment%%) (%%current-vop%%) ,label))
1402 wlott 1.1
1403 wlott 1.2 ;;; EMIT-POSTIT -- interface.
1404     ;;;
1405     (defmacro emit-postit (function)
1406 toy 1.30 `(%emit-postit (%%current-segment%%) ,function))
1407 wlott 1.2
1408 wlott 1.1 ;;; ALIGN -- interface.
1409     ;;;
1410 ram 1.26 (defmacro align (bits &optional (fill-byte 0))
1411 rtoy 1.36 "Emit an alignment restriction to the current segment."
1412 toy 1.30 `(emit-alignment (%%current-segment%%) (%%current-vop%%) ,bits ,fill-byte))
1413 wlott 1.1
1414     ;;; LABEL-POSITION -- interface.
1415     ;;;
1416     (defun label-position (label &optional if-after delta)
1417 rtoy 1.36 "Return the current position for LABEL. Chooser maybe-shrink functions
1418 wlott 1.1 should supply IF-AFTER and DELTA to assure correct results."
1419     (let ((posn (label-posn label)))
1420     (if (and if-after (> posn if-after))
1421     (- posn delta)
1422     posn)))
1423    
1424     ;;; APPEND-SEGMENT -- interface.
1425     ;;;
1426     (defun append-segment (segment other-segment)
1427 rtoy 1.36 "Append OTHER-SEGMENT to the end of SEGMENT. Don't use OTHER-SEGMENT
1428 wlott 1.1 for anything after this."
1429 wlott 1.2 (when (segment-run-scheduler segment)
1430     (schedule-pending-instructions segment))
1431     (let ((postits (segment-postits segment)))
1432     (setf (segment-postits segment) (segment-postits other-segment))
1433     (dolist (postit postits)
1434     (emit-back-patch segment 0 postit)))
1435 ram 1.26 (if (c:backend-featurep :x86)
1436     (emit-alignment segment nil max-alignment #x90)
1437     (emit-alignment segment nil max-alignment))
1438 wlott 1.1 (let ((offset-in-last-block (rem (segment-current-index segment)
1439     output-block-size)))
1440     (unless (zerop offset-in-last-block)
1441     (emit-filler segment (- output-block-size offset-in-last-block))))
1442     (let* ((blocks (segment-output-blocks segment))
1443     (next-block-num (floor (segment-current-index segment)
1444     output-block-size))
1445     (other-blocks (segment-output-blocks other-segment)))
1446     (setf blocks
1447     (adjust-array blocks (+ next-block-num (length other-blocks))))
1448     (setf (segment-output-blocks segment) blocks)
1449     (replace blocks other-blocks :start1 next-block-num))
1450     (let ((index-delta (segment-current-index segment))
1451     (posn-delta (segment-current-posn segment))
1452     (other-annotations (segment-annotations other-segment)))
1453     (setf (segment-current-index segment)
1454     (+ index-delta (segment-current-index other-segment)))
1455     (setf (segment-current-posn segment)
1456     (+ posn-delta (segment-current-posn other-segment)))
1457     (setf (segment-fill-pointer segment) (system:int-sap 0))
1458     (setf (segment-block-end segment) (system:int-sap 0))
1459     (when other-annotations
1460     (dolist (note other-annotations)
1461     (incf (annotation-index note) index-delta)
1462     (incf (annotation-posn note) posn-delta))
1463     (let ((last (segment-last-annotation segment)))
1464     (if last
1465     (setf (cdr last) other-annotations)
1466     (setf (segment-annotations segment) other-annotations))
1467     (setf (segment-last-annotation segment)
1468     (segment-last-annotation other-segment)))))
1469     (ext:undefined-value))
1470    
1471     ;;; FINALIZE-SEGMENT -- interface.
1472     ;;;
1473     (defun finalize-segment (segment)
1474 rtoy 1.36 "Does any final processing of SEGMENT and returns the total number of bytes
1475 wlott 1.1 covered by this segment."
1476     (when (segment-run-scheduler segment)
1477     (schedule-pending-instructions segment))
1478 hallgren 1.8 (setf (segment-run-scheduler segment) nil)
1479 wlott 1.2 (let ((postits (segment-postits segment)))
1480     (setf (segment-postits segment) nil)
1481     (dolist (postit postits)
1482     (emit-back-patch segment 0 postit)))
1483 wlott 1.1 (setf (segment-final-index segment) (segment-current-index segment))
1484     (setf (segment-final-posn segment) (segment-current-posn segment))
1485     (setf (segment-inst-hook segment) nil)
1486     (compress-output segment)
1487     (finalize-positions segment)
1488     (process-back-patches segment)
1489     (segment-final-posn segment))
1490    
1491     ;;; SEGMENT-MAP-OUTPUT -- interface.
1492     ;;;
1493     (defun segment-map-output (segment function)
1494 rtoy 1.36 "Call FUNCTION on all the output accumulated in SEGMENT. FUNCTION is called
1495 wlott 1.1 zero or more times with two arguments: a SAP and a number of bytes."
1496     (let ((old-index 0)
1497     (blocks (segment-output-blocks segment))
1498     (sap (system:int-sap 0))
1499     (end (system:int-sap 0)))
1500     (labels ((map-until (index)
1501     (unless (system:sap< sap end)
1502     (multiple-value-bind
1503     (block-num block-offset)
1504     (floor old-index output-block-size)
1505     (let ((block (aref blocks block-num)))
1506     (setf sap (system:sap+ block block-offset))
1507     (setf end (system:sap+ block output-block-size)))))
1508     (let* ((desired (- index old-index))
1509     (available (system:sap- end sap))
1510     (amount (min desired available)))
1511     (funcall function sap amount)
1512     (incf old-index amount)
1513     (setf sap (system:sap+ sap amount))
1514     (when (< amount desired)
1515     (map-until index)))))
1516     (dolist (note (segment-annotations segment))
1517     (when (filler-p note)
1518     (let ((index (filler-index note)))
1519     (when (< old-index index)
1520     (map-until index)))
1521     (let ((bytes (filler-bytes note)))
1522     (incf old-index bytes)
1523     (setf sap (system:sap+ sap bytes)))))
1524     (let ((index (segment-final-index segment)))
1525     (when (< old-index index)
1526     (map-until index))))))
1527    
1528     ;;; RELEASE-SEGMENT -- interface.
1529     ;;;
1530     (defun release-segment (segment)
1531 rtoy 1.36 "Releases any output buffers held on to by segment."
1532 wlott 1.1 (let ((blocks (segment-output-blocks segment)))
1533     (loop
1534     for block across blocks
1535     do (when block
1536     (release-output-block block))))
1537     (ext:undefined-value))
1538    
1539    
1540     ;;;; Interface to the instruction set definition.
1541    
1542     ;;; DEFINE-EMITTER -- Interface.
1543     ;;;
1544     ;;; Define a function named NAME that merges it's arguments into a single
1545     ;;; integer and then emits the bytes of that integer in the correct order
1546     ;;; based on the endianness of the target-backend.
1547     ;;;
1548     (defmacro define-emitter (name total-bits &rest byte-specs)
1549     (ext:collect ((arg-names) (arg-types))
1550     (let* ((total-bits (eval total-bits))
1551     (overall-mask (ash -1 total-bits))
1552     (num-bytes (multiple-value-bind
1553     (quo rem)
1554     (truncate total-bits assembly-unit-bits)
1555     (unless (zerop rem)
1556 rtoy 1.37 (error (intl:gettext "~D isn't an even multiple of ~D")
1557 wlott 1.1 total-bits assembly-unit-bits))
1558     quo))
1559     (bytes (make-array num-bytes :initial-element nil))
1560     (segment-arg (gensym "SEGMENT-")))
1561     (dolist (byte-spec-expr byte-specs)
1562     (let* ((byte-spec (eval byte-spec-expr))
1563     (byte-size (byte-size byte-spec))
1564     (byte-posn (byte-position byte-spec))
1565     (arg (gensym (format nil "~:@(ARG-FOR-~S-~)" byte-spec-expr))))
1566     (when (ldb-test (byte byte-size byte-posn) overall-mask)
1567 rtoy 1.37 (error (intl:gettext "Byte spec ~S either overlaps another byte spec, or ~
1568     extends past the end.")
1569 wlott 1.1 byte-spec-expr))
1570     (setf (ldb byte-spec overall-mask) -1)
1571     (arg-names arg)
1572     (arg-types `(type (integer ,(ash -1 (1- byte-size))
1573     ,(1- (ash 1 byte-size)))
1574     ,arg))
1575     (multiple-value-bind
1576     (start-byte offset)
1577     (floor byte-posn assembly-unit-bits)
1578     (let ((end-byte (floor (1- (+ byte-posn byte-size))
1579     assembly-unit-bits)))
1580     (flet ((maybe-ash (expr offset)
1581     (if (zerop offset)
1582     expr
1583     `(ash ,expr ,offset))))
1584     (declare (inline maybe-ash))
1585     (cond ((zerop byte-size))
1586     ((= start-byte end-byte)
1587     (push (maybe-ash `(ldb (byte ,byte-size 0) ,arg)
1588     offset)
1589     (svref bytes start-byte)))
1590     (t
1591     (push (maybe-ash
1592     `(ldb (byte ,(- assembly-unit-bits offset) 0)
1593     ,arg)
1594     offset)
1595     (svref bytes start-byte))
1596     (do ((index (1+ start-byte) (1+ index)))
1597     ((>= index end-byte))
1598     (push
1599     `(ldb (byte ,assembly-unit-bits
1600     ,(- (* assembly-unit-bits
1601     (- index start-byte))
1602     offset))
1603     ,arg)
1604     (svref bytes index)))
1605     (let ((len (rem (+ byte-size offset)
1606     assembly-unit-bits)))
1607     (push
1608     `(ldb (byte ,(if (zerop len)
1609     assembly-unit-bits
1610     len)
1611     ,(- (* assembly-unit-bits
1612     (- end-byte start-byte))
1613     offset))
1614     ,arg)
1615     (svref bytes end-byte))))))))))
1616     (unless (= overall-mask -1)
1617 rtoy 1.37 (error (intl:gettext "There are holes.")))
1618 wlott 1.1 (let ((forms nil))
1619     (dotimes (i num-bytes)
1620     (let ((pieces (svref bytes i)))
1621     (assert pieces)
1622     (push `(emit-byte ,segment-arg
1623     ,(if (cdr pieces)
1624     `(logior ,@pieces)
1625     (car pieces)))
1626     forms)))
1627     `(defun ,name (,segment-arg ,@(arg-names))
1628     (declare (type segment ,segment-arg) ,@(arg-types))
1629     ,@(ecase (c:backend-byte-order c:*target-backend*)
1630     (:little-endian (nreverse forms))
1631     (:big-endian forms))
1632     ',name)))))
1633    
1634 wlott 1.3 (defun grovel-lambda-list (lambda-list vop-var)
1635 wlott 1.1 (let ((segment-name (car lambda-list))
1636 wlott 1.3 (vop-var (or vop-var (gensym "VOP-"))))
1637 wlott 1.1 (ext:collect ((new-lambda-list))
1638     (new-lambda-list segment-name)
1639     (new-lambda-list vop-var)
1640     (labels
1641     ((grovel (state lambda-list)
1642     (when lambda-list
1643     (let ((param (car lambda-list)))
1644     (cond
1645     ((member param lambda-list-keywords)
1646     (new-lambda-list param)
1647     (grovel param (cdr lambda-list)))
1648     (t
1649     (ecase state
1650     ((nil)
1651     (new-lambda-list param)
1652     `(cons ,param ,(grovel state (cdr lambda-list))))
1653     (&optional
1654     (multiple-value-bind
1655     (name default supplied-p)
1656     (if (consp param)
1657     (values (first param)
1658     (second param)
1659     (or (third param)
1660     (gensym "SUPPLIED-P-")))
1661     (values param nil (gensym "SUPPLIED-P-")))
1662     (new-lambda-list (list name default supplied-p))
1663     `(and ,supplied-p
1664     (cons ,(if (consp name)
1665     (second name)
1666     name)
1667     ,(grovel state (cdr lambda-list))))))
1668     (&key
1669     (multiple-value-bind
1670     (name default supplied-p)
1671     (if (consp param)
1672     (values (first param)
1673     (second param)
1674     (or (third param)
1675     (gensym "SUPPLIED-P-")))
1676     (values param nil (gensym "SUPPLIED-P-")))
1677     (new-lambda-list (list name default supplied-p))
1678     (multiple-value-bind
1679     (key var)
1680     (if (consp name)
1681     (values (first name) (second name))
1682     (values (intern (symbol-name name) :keyword)
1683     name))
1684     `(append (and ,supplied-p (list ',key ,var))
1685     ,(grovel state (cdr lambda-list))))))
1686     (&rest
1687     (new-lambda-list param)
1688     (grovel state (cdr lambda-list))
1689     param))))))))
1690     (let ((reconstructor (grovel nil (cdr lambda-list))))
1691     (values (new-lambda-list)
1692     segment-name
1693     vop-var
1694     reconstructor))))))
1695    
1696 wlott 1.6 (defun extract-nths (index glue list-of-lists-of-lists)
1697     (mapcar #'(lambda (list-of-lists)
1698     (cons glue
1699     (mapcar #'(lambda (list)
1700     (nth index list))
1701     list-of-lists)))
1702     list-of-lists-of-lists))
1703    
1704 wlott 1.1 ;;; DEFINE-INSTRUCTION -- interface.
1705     ;;;
1706     (defmacro define-instruction (name lambda-list &rest options)
1707     (let* ((sym-name (symbol-name name))
1708     (defun-name (ext:symbolicate sym-name "-INST-EMITTER"))
1709 wlott 1.3 (vop-var nil)
1710 wlott 1.2 (postits (gensym "POSTITS-"))
1711 wlott 1.1 (emitter nil)
1712     (decls nil)
1713     (attributes nil)
1714 hallgren 1.22 (cost nil)
1715 wlott 1.17 (dependencies nil)
1716 wlott 1.1 (delay nil)
1717 wlott 1.6 (pinned nil)
1718 wlott 1.18 (pdefs nil))
1719 wlott 1.3 (dolist (option-spec options)
1720     (multiple-value-bind
1721     (option args)
1722     (if (consp option-spec)
1723     (values (car option-spec) (cdr option-spec))
1724     (values option-spec nil))
1725     (case option
1726     (:emitter
1727     (when emitter
1728 rtoy 1.37 (error (intl:gettext "Can only specify one emitter per instruction.")))
1729 wlott 1.3 (setf emitter args))
1730     (:declare
1731     (setf decls (append decls args)))
1732     (:attributes
1733     (setf attributes (append attributes args)))
1734 hallgren 1.22 (:cost
1735     (setf cost (first args)))
1736 wlott 1.17 (:dependencies
1737     (setf dependencies (append dependencies args)))
1738 wlott 1.3 (:delay
1739 wlott 1.17 (when delay
1740 rtoy 1.37 (error (intl:gettext "Can only specify delay once per instruction.")))
1741 wlott 1.17 (setf delay args))
1742 wlott 1.3 (:pinned
1743     (setf pinned t))
1744     (:vop-var
1745     (if vop-var
1746 rtoy 1.37 (error (intl:gettext "Can only specify :vop-var once."))
1747 wlott 1.3 (setf vop-var (car args))))
1748 wlott 1.6 (:printer
1749     (push
1750     (eval
1751     `(list
1752     (multiple-value-list
1753     ,(disassem:gen-printer-def-forms-def-form name
1754     (cdr option-spec)))))
1755     pdefs))
1756     (:printer-list
1757     ;; same as :printer, but is evaled first, and is a list of printers
1758     (push
1759     (eval
1760     `(eval
1761     `(list ,@(mapcar #'(lambda (printer)
1762     `(multiple-value-list
1763     ,(disassem:gen-printer-def-forms-def-form
1764     ',name printer nil)))
1765     ,(cadr option-spec)))))
1766     pdefs))
1767 wlott 1.3 (t
1768 rtoy 1.37 (error (intl:gettext "Unknown option: ~S") option)))))
1769 wlott 1.6 (setf pdefs (nreverse pdefs))
1770 wlott 1.1 (multiple-value-bind
1771     (new-lambda-list segment-name vop-name arg-reconstructor)
1772 wlott 1.3 (grovel-lambda-list lambda-list vop-var)
1773 wlott 1.1 (push `(let ((hook (segment-inst-hook ,segment-name)))
1774     (when hook
1775     (funcall hook ,segment-name ,vop-name ,sym-name
1776     ,arg-reconstructor)))
1777     emitter)
1778 wlott 1.2 (push `(dolist (postit ,postits)
1779     (emit-back-patch ,segment-name 0 postit))
1780 hallgren 1.22 emitter)
1781     (unless cost (setf cost 1))
1782     (push `(when (segment-collect-dynamic-statistics ,segment-name)
1783     (let* ((info (c:ir2-component-dyncount-info
1784     (c:component-info c:*compile-component*)))
1785     (costs (c:dyncount-info-costs info))
1786     (block-number (c:block-number
1787     (c:ir2-block-block
1788     (c:vop-block ,vop-name)))))
1789 hallgren 1.23 (incf (aref costs block-number) ,cost)))
1790 wlott 1.2 emitter)
1791 wlott 1.1 (when (assem-params-scheduler-p
1792     (c:backend-assembler-params c:*target-backend*))
1793     (if pinned
1794     (setf emitter
1795     `((when (segment-run-scheduler ,segment-name)
1796     (schedule-pending-instructions ,segment-name))
1797     ,@emitter))
1798     (let ((flet-name
1799 wlott 1.17 (gensym (concatenate 'string "EMIT-" sym-name "-INST-")))
1800     (inst-name (gensym "INST-")))
1801 wlott 1.1 (setf emitter `((flet ((,flet-name (,segment-name)
1802     ,@emitter))
1803     (if (segment-run-scheduler ,segment-name)
1804 wlott 1.17 (let ((,inst-name
1805     (make-instruction
1806     (incf (segment-inst-number
1807     ,segment-name))
1808     #',flet-name
1809     (instruction-attributes
1810     ,@attributes)
1811     (progn ,@delay))))
1812     ,@(when dependencies
1813     `((note-dependencies
1814     (,segment-name ,inst-name)
1815     ,@dependencies)))
1816     (queue-inst ,segment-name ,inst-name))
1817 wlott 1.1 (,flet-name ,segment-name))))))))
1818     `(progn
1819     (defun ,defun-name ,new-lambda-list
1820     ,@(when decls
1821     `((declare ,@decls)))
1822 wlott 1.2 (let ((,postits (segment-postits ,segment-name)))
1823     (setf (segment-postits ,segment-name) nil)
1824 toy 1.30 (macrolet ((%%current-segment%% ()
1825 rtoy 1.37 (error (intl:gettext "You can't use INST without an ASSEMBLE inside emitters."))))
1826 wlott 1.2 ,@emitter))
1827 wlott 1.1 (ext:undefined-value))
1828 pw 1.29 (eval-when (compile load eval)
1829 wlott 1.6 (%define-instruction ,sym-name ',defun-name))
1830     ,@(extract-nths 1 'progn pdefs)
1831 wlott 1.18 ,@(when pdefs
1832     `((disassem:install-inst-flavors
1833     ',name
1834     (append ,@(extract-nths 0 'list pdefs)))))))))
1835 wlott 1.1
1836     ;;; DEFINE-INSTRUCTION-MACRO -- interface.
1837     ;;;
1838     (defmacro define-instruction-macro (name lambda-list &body body)
1839     (let ((whole (gensym "WHOLE-"))
1840     (env (gensym "ENV-")))
1841     (multiple-value-bind
1842     (body local-defs)
1843     (lisp::parse-defmacro lambda-list whole body name 'instruction-macro
1844     :environment env)
1845 pw 1.29 `(eval-when (compile load eval)
1846 wlott 1.3 (%define-instruction ,(symbol-name name)
1847 wlott 1.1 #'(lambda (,whole ,env)
1848     ,@local-defs
1849     (block ,name
1850 wlott 1.3 ,body)))))))
1851 wlott 1.1
1852     (defun %define-instruction (name defun)
1853     (setf (gethash name
1854     (assem-params-instructions
1855     (c:backend-assembler-params c:*target-backend*)))
1856     defun)
1857     name)
1858 wlott 1.3

  ViewVC Help
Powered by ViewVC 1.1.5