source: trunk/source/compiler/vinsn.lisp

Last change on this file was 16738, checked in by gb, 3 years ago

*remove-trivisl-copies* defaults to T.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 94.1 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;; Copyright 1994-2009 Clozure Associates
4;;;
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
8;;;
9;;;     http://www.apache.org/licenses/LICENSE-2.0
10;;;
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
16
17(cl:in-package "CCL")
18
19(cl:eval-when (:compile-toplevel :load-toplevel :execute)
20  (require "DLL-NODE")
21  (require "BACKEND"))
22
23(defparameter *linear-scan-verbose* nil)
24
25
26(defun ls-format (&rest args )
27  (when (and *backend-use-linear-scan* *linear-scan-verbose*)
28    (apply #'format *debug-io* args)))
29(defun ls-break (&rest args)
30  (when (and *backend-use-linear-scan* *linear-scan-verbose*)
31    (apply #'break args)))
32
33(defun ls-note (&rest args)
34  (when (and *backend-use-linear-scan* *linear-scan-verbose*)
35    (apply #'warn args)))
36
37(cl:in-package "CCL")
38
39;;; Specifying the same name for a result and an argument basically
40;;; says that it's ok for the vinsn to clobber that argument.  (In all
41;;; other cases, arguments are assumed to be "read-only", and damned
42;;; well better be.)  Any results that are also arguments must follow
43;;; all results that aren't in the "results" list; any arguments that
44;;; are also results must precede all arguments that aren't in the
45;;; "arguments" list, and all hybrids must appear in the same order in
46;;; both lists. This is what "nhybrids" is about (and why it defaults
47;;; to 0 ...)  Sometimes (often) these hybrid "results" aren't very
48;;; interesting as results;;; it might be clearer to consider
49;;; "mutable" arguments as quasi-temporaries.
50
51(defstruct vinsn-template
52  name                                  ; a symbol in the target package
53  result-vreg-specs                     ; one or more vreg specs for values defined by the vinsn
54  argument-vreg-specs                   ; may ultimately overlap some result vreg(s)
55  ; one or more vreg specs for temporaries used in vinsn.
56  ; all such temporaries are assumed to have lifetimes which span all
57  ; machine instructions in the vinsn (e.g., they can't conflict with any
58  ; registers used for args/results and may have further constraints.
59  temp-vreg-specs                 
60  local-labels
61  body                                  ; list of target instructions, local labels
62  (nhybrids 0)
63  (nvp 0)
64  results&args                          ;
65  (attributes 0)                        ; attribute bitmask
66  opcode-alist                          ; ((number1 . name1) (number2 . name2) ...)
67)
68
69(defmethod make-load-form ((v vinsn-template) &optional env)
70  (make-load-form-saving-slots v :environment env))
71
72(defstatic *empty-vinsn-template* (make-vinsn-template))
73
74(defun get-vinsn-template-cell (name templates)
75  (let* ((n (intern (string name) *ccl-package*)))
76    (or (gethash n templates)
77        (setf (gethash n templates) (cons n nil)))))
78
79(defun need-vinsn-template (name templates)
80  (or (cdr (if (consp name) name (get-vinsn-template-cell name templates)))
81      (error "Unknown vinsn: ~s" name)))
82
83(defun set-vinsn-template (name template templates)
84  (setf (cdr (get-vinsn-template-cell name templates)) template))
85
86(defstruct (vinsn (:include dll-node)
87                  (:print-function print-vinsn)
88                  (:constructor %make-vinsn (template)))
89  template                              ; The vinsn-template of which this is an instance
90  variable-parts                        ; vector of result-vregs, arguments, temps, local-labels
91  annotation
92  (gprs-set 0)
93  (fprs-set 0)
94  (gprs-read 0)
95  (fprs-read 0)
96  (notes ())
97  (sequence 0 :type fixnum)
98  fgn
99)
100
101
102(defun make-vinsn (template)
103  (%make-vinsn template))
104
105(eval-when (:load-toplevel :execute)
106(defstruct (vinsn-label (:include dll-node)
107                        (:print-function print-vinsn-label)
108                        (:predicate %vinsn-label-p)
109                        (:constructor %make-vinsn-label (id)))
110  id
111  refs                                  ; vinsns in which this label appears as an operand
112  info                                  ; code-generation stuff
113) 
114)
115(defstruct (vinsn-list (:include dll-header)
116                       (:constructor %make-vinsn-list))
117  (lregs (make-array 64 :fill-pointer 0 :adjustable t))
118  flow-graph
119  (intervals (make-array 64 :fill-pointer 0 :adjustable t))
120  max-seq
121  (spill-base 0 :type fixnum)
122  (spill-depth 0 :type fixnum)
123  (max-spill-depth 0 :type fixnum )
124  (spill-area-used (make-array 64 :element-type 'bit))
125  (available-physical-registers #() :type simple-vector)
126  (nfp-spill-offset 0 :type fixnum)
127  (max-nfp-spill-depth 0 :type fixnum)
128  )
129
130(defun make-vinsn-list ()
131  (init-dll-header (%make-vinsn-list)))
132
133(defvar *vinsn-list*)
134                   
135(defun make-vinsn-label (id)
136  (%make-vinsn-label id))
137
138; "Real" labels have fixnum IDs.
139(defun vinsn-label-p (l)
140  (if (%vinsn-label-p l) 
141    (typep (vinsn-label-id l) 'fixnum)))
142
143
144(defun print-vinsn-label (l s d)
145  (declare (ignore d))
146  (print-unreadable-object (l s :type t)
147    (format s "~d" (vinsn-label-id l))))
148
149;;; Notes are attached to (some) vinsns.  They're used to attach
150;;; semantic information to an execution point.  The vinsn
151;;; points to the note via its LABEL-ID; the note has a backpointer to
152;;; the vinsn.
153
154(defstruct (vinsn-note
155            (:constructor %make-vinsn-note)
156            (:print-function print-vinsn-note))
157  (address nil)                           ; lap label
158  (peer nil :type (or null vinsn-note))
159  (class nil)
160  (info nil :type (or null simple-vector))
161  (container nil  :type (or null vinsn)))
162
163
164(defun add-vinsn-note (note vinsn)
165  (push note (vinsn-notes vinsn))
166  (setf (vinsn-note-container note) vinsn))
167
168
169
170
171
172(defun print-vinsn-note (n s d)
173  (declare (ignore d))
174  (print-unreadable-object (n s :type t)
175    (format s "~d" (vinsn-note-class n))
176    (let* ((info (vinsn-note-info n)))
177      (when info (format s " / ~S" info)))))
178 
179(defun make-vinsn-note (class info)
180  (%make-vinsn-note :class class :info (if info (apply #'vector info))))
181
182(defun enqueue-vinsn-note (seg class &rest info)
183  (let* ((note (make-vinsn-note class info)))
184    (push note (dll-header-info seg))
185    note))
186
187(defun close-vinsn-note (seg n)
188  (let* ((vinsn (last-vinsn seg)))
189    (unless vinsn
190      (nx-error "No last vinsn in ~s." seg))
191    (let* ((end (%make-vinsn-note :peer n :class :close)))
192      #+debug
193      (format t "~& adding note ~s to vinsn ~s, closing ~s" end vinsn n)
194      (add-vinsn-note end vinsn)
195      (setf (vinsn-note-peer n) end))))
196
197       
198
199(defun vinsn-vreg-description (value spec)
200  (case (cadr spec)
201    ((:u32 :s32 :u16 :s16 :u8 :s8 :lisp :address :imm)
202     (let* ((mode (if (typep value 'fixnum)
203                    (get-regspec-mode value))))
204       (if (and mode (not (eql 0 mode)))
205         (list (hard-regspec-value value)
206               (car (rassoc mode *mode-name-value-alist* :test #'eq)))
207         value)))
208    (t value)))
209
210(defun collect-vinsn-variable-parts (v start n &optional specs)
211  (declare (fixnum start n))
212  (let* ((varparts (vinsn-variable-parts v)))
213    (when varparts
214      (let* ((head (cons nil nil))
215             (tail head))
216        (declare (dynamic-extent head) (cons head tail))
217        (do* ((j start (1+ j))
218              (i 0 (1+ i)))
219             ((= i n) (cdr head))
220          (declare (fixnum i j))
221          (setq tail (cdr (rplacd tail (cons (vinsn-vreg-description (svref varparts j) (pop specs)) nil)))))))))
222
223     
224(defun collect-vinsn-results (v)
225  (let* ((template (vinsn-template v))
226         (result-specs (vinsn-template-result-vreg-specs template)))
227    (collect-vinsn-variable-parts v 0 (length result-specs) result-specs)))
228
229(defun collect-vinsn-arguments (v)
230  (let* ((template (vinsn-template v))
231         (arg-specs (vinsn-template-argument-vreg-specs template)))
232    (collect-vinsn-variable-parts v
233                                  (- (length (vinsn-template-result-vreg-specs template)) 
234                                     (vinsn-template-nhybrids template))
235                                  (length arg-specs)
236                                  arg-specs)))
237
238(defun collect-vinsn-temps (v)
239  (let* ((template (vinsn-template v)))
240    (collect-vinsn-variable-parts v 
241                                  (+
242                                   (length (vinsn-template-result-vreg-specs template)) 
243                                   (length (vinsn-template-argument-vreg-specs template)))
244                                  (length (vinsn-template-temp-vreg-specs template)))))
245
246(defun template-infix-p (template)
247  (declare (ignore template))
248  nil)
249
250(defun print-vinsn (v stream d)
251  (declare (ignore d))
252  (let* ((template (vinsn-template v))
253         (results (collect-vinsn-results v))
254         (args (collect-vinsn-arguments v))
255         (opsym (if (cdr results) :== :=))
256         (infix (and (= (length args) 2) (template-infix-p template)))
257         (opname (vinsn-template-name template))
258         (sequence (vinsn-sequence v)))
259    (when (and (vinsn-attribute-p v :subprim)
260               (typep (car args) 'integer))
261      (let* ((spinfo (find (car args)
262                           (arch::target-subprims-table
263                            (backend-target-arch *target-backend*))
264                           :key #'subprimitive-info-offset)))
265        (when spinfo
266          (setf (car args) (subprimitive-info-name spinfo)))))
267    (print-unreadable-object (v stream)
268      (when sequence (format stream "@~d " sequence))
269      (if results (format stream "~A ~S " (if (cdr results) results (car results)) opsym))
270      (if infix
271        (format stream "~A ~A ~A" (car args) opname (cadr args))
272        (format stream "~A~{ ~A~}" opname args))
273      (let* ((annotation (vinsn-annotation v)))
274        (when annotation
275          (format stream " ||~a|| " annotation))))))
276
277(eval-when (:compile-toplevel :load-toplevel :execute)
278(defparameter *known-vinsn-attributes*
279  '(
280    :jump                               ; an unconditional branch
281    :branch                             ; a conditional branch
282    :call                               ; a jump that returns
283    :align                              ; aligns FOLLOWING label
284    :subprim                            ; first argument is a subprim address
285    :jumpLR                             ; Jumps to the LR, possibly stopping off at a function along the way.
286    :extended-call                      ; extend call interval
287    :lrrestore                               ; suppress ref/def tracking
288    :lispcontext                        ; references lisp frame LOC-PC, FN, and entry VSP
289    :node                               ; saves/restores a node value in stack-like memory
290    :word                               ; saves/restores an unboxed word in stack-like memory
291    :spill
292    :vsp                                ; uses the vsp to save/restore
293    :tsp                                ; uses the tsp to save/restore
294    :reload                             ;
295    :push                               ; saves something
296    :pop                                ; restores something
297    :multiple                           ; saves/restores multiple nodes/words/doublewords
298    :ref                                ; references memory
299    :set                                ; sets memory
300    :uses-frame-pointer                 ; uses frame pointer
301    :needs-frame-pointer                ; needs to use frame pointer
302    :jump-unknown                       ; Jumps, but we don't know where ...
303    :constant-ref
304    :trivial-copy                       ; may be a useless vinsn
305    :discard                            ; adjusts a stack pointer
306    :nfp                                ; references the nfp
307    :predicatable                       ; all instructions can be predicated, no instructions set or test condition codes.
308    :sets-lr                            ; uses the link register, if there is one.
309    )))
310
311
312;;; This should only be called by old code during bootstrapping.
313(defun free-varparts-vector (v)
314  (declare (ignore v)))
315
316
317
318(defun distribute-vinsn-notes (notes pred succ)
319  (or (null notes)
320      (and (dolist (note notes t)
321             (unless (if (eq :close (vinsn-note-class note))
322                       (typep pred 'vinsn)
323                       (typep succ 'vinsn))
324               (return nil)))
325           (dolist (note notes t)
326             (if (eq :close (vinsn-note-class note))
327               (add-vinsn-note note pred)
328               (add-vinsn-note note succ))))))
329               
330
331(defun elide-vinsn (vinsn)
332  (let* ((template (vinsn-template vinsn))
333             (nvp (vinsn-template-nvp template))
334             (vp (vinsn-variable-parts vinsn)))
335        (dotimes (i nvp)
336          (let* ((v (svref vp i)))
337            (when (typep v 'vinsn-label)
338              (setf (vinsn-label-refs v)
339                    (delete vinsn (vinsn-label-refs v))))
340            (when (typep v 'lreg)
341              (setf (lreg-defs v) (delete vinsn (lreg-defs v)))
342              (setf (lreg-refs v) (delete vinsn (lreg-refs v))))))
343        (setf (vinsn-variable-parts vinsn) nil)
344        (if (distribute-vinsn-notes (vinsn-notes vinsn) (vinsn-pred vinsn) (vinsn-succ vinsn))
345          (remove-dll-node vinsn)
346          (setf (vinsn-template vinsn) *empty-vinsn-template*))))
347   
348(defun encode-vinsn-attributes (attribute-list)
349  (flet ((attribute-weight (k)
350           (let* ((pos (position k *known-vinsn-attributes*)))
351             (if pos (ash 1 pos) (error "Unknown vinsn attribute: ~s" k)))))
352    (let* ((attr 0))
353      (declare (fixnum attr))
354      (dolist (a attribute-list attr)
355        (setq attr (logior attr (the fixnum (attribute-weight a))))))))
356
357
358(defun %define-vinsn (backend vinsn-name results args temps body)
359  (funcall (backend-define-vinsn backend)
360           backend
361           vinsn-name
362           results
363           args
364           temps
365           body))
366
367
368;; Fix the opnum's in the vinsn-template-body to agree with the
369;; backend's opcode hash table.
370(defun fixup-vinsn-template (orig-template opcode-hash)
371  (let ((template (cdr orig-template)))
372    (when template
373      (unless (vinsn-template-p template)
374        (setq template (require-type template 'vinsn-template)))
375      (let ((new-opcode-alist nil)
376            (changes nil)
377            (opcode-alist (vinsn-template-opcode-alist template)))
378        ;; this is patterned after ppc2-expand-vinsn
379        (labels ((walk-form (f)
380                   (unless (atom f)
381                     (if (fixnump (car f))
382                       (got-one f)
383                        (dolist (subform (cdr f))
384                         (walk-form subform)))))
385                 (got-one (f)
386                   (let* ((old-opcode (car f))
387                          (name (cdr (assq old-opcode opcode-alist)))
388                          (new-opcode (and name (gethash name opcode-hash))))
389                     (unless new-opcode
390                       (cerror "Continue" "Can't find new opcode number ~
391                                   for ~s in ~s" (car f) template))
392                     (setf (assq new-opcode new-opcode-alist) name)
393                     (unless (eq new-opcode old-opcode)
394                       (push (cons f new-opcode) changes)))))
395          (mapc #'walk-form (vinsn-template-body template))
396          (without-interrupts
397           (dolist (change changes)
398             (setf (caar change) (cdr change)))
399           (setf (vinsn-template-opcode-alist template)
400                 new-opcode-alist))))
401      orig-template)))
402
403(defun fixup-vinsn-templates (templates opcode-hash-table)
404  (maphash #'(lambda (name template)
405               (declare (ignore name))
406               (fixup-vinsn-template template opcode-hash-table))
407           templates))
408
409
410
411
412;;; Could probably split this up and do some arg checking at macroexpand time.
413
414(defun match-template-vregs (template vinsn supplied-vregs)
415  (declare (list supplied-vregs))
416  (let* ((nsupp (length supplied-vregs))
417         (results&args (vinsn-template-results&args template))
418         (nra (length results&args))
419         (temp-specs (vinsn-template-temp-vreg-specs template))
420         (ntemps (length temp-specs))
421         (nvp (vinsn-template-nvp template))
422         (vp (make-array nvp))
423         (*available-backend-node-temps* *available-backend-node-temps*)
424         (*available-backend-fp-temps* *available-backend-fp-temps*)
425         (*available-backend-imm-temps* *available-backend-imm-temps*)
426         (*available-backend-crf-temps* *available-backend-crf-temps*))
427    (declare (fixnum nvp ntemps nsupp)
428             (list temp-specs))
429    (unless (= nsupp nra)
430      (error "Vinsn ~A expects ~D result/argument specs, received ~D ."
431             (vinsn-template-name template) nra nsupp))
432    (do* ((i 0 (1+ i))
433          (supp supplied-vregs (cdr supp))
434          (spec results&args (cdr spec)))
435         ((null supp))
436      (declare (fixnum i) (list spec supp))
437      (setf (svref vp i) (match-vreg (car supp) (cadar spec) vinsn vp i)))
438    ;; Allocate some temporaries.
439    (do* ((i (- nvp ntemps) (1+ i))
440          (temps temp-specs (cdr temps)))
441         ((null temps) vp)
442      (declare (fixnum i))
443      (let* ((spec (cadar temps)))
444        (if (and (consp spec) (eq (car spec) :label))
445          (let* ((label (aref *backend-labels* (cadr spec))))
446            (push vinsn (vinsn-label-refs label))
447            (setf (svref vp i) label))
448          (let* ((lreg (allocate-temporary-vreg (car temps)))
449                 (class (hard-regspec-class lreg))
450                 (value (hard-regspec-value lreg)))
451            (when value
452              (case class
453                (#.hard-reg-class-gpr (note-vinsn-sets-gpr vinsn value))
454                (#.hard-reg-class-fpr (note-vinsn-sets-fpr-lreg vinsn lreg))))
455            (setf (svref vp i) lreg)
456
457            (pushnew vinsn (lreg-defs lreg))
458            (pushnew vinsn (lreg-refs lreg))))))))
459
460;;; "spec" is (<name> <class>).
461;;;  <class> is keyword or (<keyword> <val>)
462(defun allocate-temporary-vreg (spec)
463  (setq spec (cadr spec))
464  (let* ((class (if (atom spec) spec (car spec)))
465         (value (if (atom spec) nil (cadr spec))))
466    (if value
467      (ecase class
468        (:crf (make-wired-lreg (use-crf-temp value) :local-p t  :class hard-reg-class-crf))
469        ((:u8 :s8 :u16 :s16 :u32 :s32 :u64 :s64) 
470         (make-wired-lreg (use-imm-temp value)
471                          :local-p t
472                          :class hard-reg-class-gpr
473                          :mode (gpr-mode-name-value class)))
474        (:lisp (make-wired-lreg
475                (use-node-temp value) 
476                :local-p t
477                :class hard-reg-class-gpr
478                :mode hard-reg-class-gpr-mode-node))
479        ((:single-float :double-float :complex-double-float :complex-single-float)
480         (let* ((lreg (make-wired-lreg value
481                                       :local-p t
482                                       :class hard-reg-class-fpr
483                                       :mode (fpr-mode-name-value class))))
484                         (use-fp-reg lreg)
485                         lreg)))
486      (ecase class
487        ((:imm :wordptr) 
488         (make-unwired-lreg
489          (if (= *available-backend-imm-temps* 0) (select-node-temp) (select-imm-temp))
490              :class hard-reg-class-gpr
491              :mode hard-reg-class-gpr-mode-node)) 
492        ((:u8 :s8 :u16 :s16 :u32 :s32 :u64 :s64 :address) 
493         (make-unwired-lreg (select-imm-temp)
494                            :class hard-reg-class-gpr
495                            :mode (gpr-mode-name-value class)))
496        ((:double-float :single-float :complex-double-float :complex-single-float)
497         (let* ((lreg (make-unwired-lreg (select-fp-temp class)
498                                         :class hard-reg-class-fpr
499                                         :mode (fpr-mode-name-value class))))
500           (use-fp-reg lreg)
501           lreg))
502        (:lisp 
503         (make-unwired-lreg 
504          (select-node-temp) 
505          :class hard-reg-class-gpr
506          :mode hard-reg-class-gpr-mode-node))
507        (:crf 
508         (make-unwired-lreg (select-crf-temp) :class hard-reg-class-crf))))))
509
510
511
512
513
514
515(defun select-vinsn (template-or-name template-hash vregs)
516  (let* ((template (need-vinsn-template template-or-name template-hash))
517         (vinsn (make-vinsn template)))
518    (setf (vinsn-variable-parts vinsn) (match-template-vregs template vinsn vregs))
519    vinsn))
520
521(defun %emit-vinsn (vlist name vinsn-table &rest vregs)
522  (let* ((vinsn (select-vinsn name vinsn-table vregs))
523         (notes (dll-header-info vlist)))
524    (when notes
525      (dolist (note notes (setf (dll-header-info vlist) nil))
526        (push note (vinsn-notes vinsn))))
527    (append-dll-node vinsn vlist)))
528
529(defun varpart-matches-reg (varpart-value class regval spec)
530  (setq spec (if (atom spec) spec (car spec)))
531  (and
532   (or
533    (and (eq class hard-reg-class-fpr)
534         (memq spec '(:single-float :double-float :complex-single-float :complex-double-float)))
535    (and (eq class hard-reg-class-gpr)
536         (memq spec '(:u32 :s32 :u16 :s16 :u8 :s8 :lisp :address :imm))))
537   (eq (hard-regspec-value varpart-value) regval)))
538
539(defun vinsn-refs-reg-p (element reg)
540  (if (typep element 'vinsn)
541    (if (vinsn-attribute-p element :call)
542      t
543      (let* ((class (hard-regspec-class reg))
544             (value (hard-regspec-value reg)))
545        (if (eq class hard-reg-class-gpr)
546          (logbitp value (vinsn-gprs-read element))
547          (if (eq class hard-reg-class-fpr)
548            ;; The FPR is logically read in the vinsn if it or any
549            ;; conflicting FPR is physically read in the vinsn.
550            (logtest (fpr-mask-for-vreg reg) (vinsn-fprs-read element))))))))
551
552(defun vinsn-sets-reg-p (element reg)
553  (if (typep element 'vinsn)
554    (if (vinsn-attribute-p element :call)
555      t
556      (let* ((class (hard-regspec-class reg))
557             (value (hard-regspec-value reg)))
558        (if (eq class hard-reg-class-gpr)
559          (logbitp value (vinsn-gprs-set element))
560          (if (eq class hard-reg-class-fpr)
561            ;; The FPR is logically set in the vinsn if it or any
562            ;; conflicting FPR is physically set in the vinsn.
563            (logtest (fpr-mask-for-vreg reg) (vinsn-fprs-set element))))))))
564
565;;; Return bitmasks of all GPRs and all FPRs set in the vinsns between
566;;; START and END, exclusive.  Any :call vinsn implicitly clobbers
567;;; all registers.
568(defun regs-set-in-vinsn-sequence (start end)
569  (let* ((gprs-set 0)
570         (fprs-set 0))
571    (do* ((element (dll-node-succ start) (dll-node-succ element)))
572         ((eq element end) (values gprs-set fprs-set))
573      (if (typep element 'vinsn)
574        (if (vinsn-attribute-p element :call)
575          (return (values #xffffffff #xffffffff))
576          (setq gprs-set (logior gprs-set (vinsn-gprs-set element))
577                fprs-set (logior fprs-set (vinsn-fprs-set element))))))))
578
579
580     
581;;; If any vinsn between START and END (exclusive) sets REG, return
582;;; that vinsn; otherwise, return NIL.
583(defun vinsn-sequence-sets-reg-p (start end reg)
584  (do* ((element (dll-node-succ start) (dll-node-succ element)))
585       ((eq element end))
586    (if (vinsn-sets-reg-p element reg)
587      (return element))))
588       
589;;; If any vinsn between START and END (exclusive) refs REG, return
590;;; the last such vinsn; otherwise, return NIL.
591(defun vinsn-sequence-refs-reg-p (start end reg)
592  (do* ((element (dll-node-pred end) (dll-node-pred element)))
593       ((eq element start))
594    (if (vinsn-refs-reg-p element reg)
595      (return element))))
596
597
598;;; Return T if any vinsn between START and END (exclusive) has all
599;;; attributes set in ATTR set.
600(defun %vinsn-sequence-has-attribute-p (start end attr)
601  (do* ((element (dll-node-succ start) (dll-node-succ element)))
602       ((eq element end))
603    (when (typep element 'vinsn)
604      (when (eql attr (logand (vinsn-template-attributes (vinsn-template element)) attr))
605        (return t)))))
606
607;;; Return T if any vinsn between START and END (exclusive) has some
608;;; some attributes set in attr set.
609(defun %vinsn-sequence-has-some-attribute-p (start end attr)
610  (do* ((element (dll-node-succ start) (dll-node-succ element)))
611       ((eq element end))
612    (when (typep element 'vinsn)
613      (when (logtest attr (vinsn-template-attributes (vinsn-template element)))
614        (return t)))))
615
616(defmacro vinsn-sequence-has-attribute-p (start end &rest attrs)
617  `(%vinsn-sequence-has-attribute-p ,start ,end ,(encode-vinsn-attributes attrs)))
618
619(defmacro vinsn-sequence-has-some-attribute-p (start end &rest attrs)
620  `(%vinsn-sequence-has-some-attribute-p ,start ,end ,(encode-vinsn-attributes attrs)))
621
622;;; Return T iff vinsn is between START and END (exclusive).
623(defun vinsn-in-sequence-p (vinsn start end)
624  (do* ((element (dll-node-succ start) (dll-node-succ element)))
625       ((eq element end))
626    (when (eq vinsn element)
627      (return t))))
628
629(defun last-vinsn (seg &optional (after seg))
630  ;; Try to find something that isn't a SOURCE-NOTE.  Go ahead.  I dare you.
631  (do* ((element (dll-header-last seg) (dll-node-pred element)))
632       ((eq element after))               ;told ya!
633    (when (typep element 'vinsn)
634      (return element))))
635
636
637;;; Flow-graph nodes (FGNs)
638
639(defstruct (fgn (:include dll-header))
640  (id 0 :type unsigned-byte)
641  (inedges ())                          ; list of nodes which reference this node
642  (outedges ())
643  (visited nil)                         ; Boolean
644  live-gen
645  live-kill
646  live-out
647  live-in
648  spills                                ; alist of intervals spilled here
649  reloads                               ; same as above
650  extended-pred
651  extended-succ
652  call-vinsns
653)
654
655(defmethod print-object (( node fgn) stream)
656  (print-unreadable-object (node stream :type t :identity t)
657    (format stream "(~s)" (fgn-id node))))
658
659
660
661(defconstant interval-pre-spilled-bit 1)
662(defconstant interval-flag-pre-spilled (ash 1 interval-pre-spilled-bit))
663
664
665
666
667;;; FGNs which don't terminate with an "external jump"
668;;; (jump-return-pc/jump-subprim, etc) jump to their successor, either
669;;; explicitly or by falling through.  We can introduce or remove
670;;; jumps when linearizing the program.
671(defstruct (jumpnode (:include fgn)
672                               (:constructor %make-jumpnode (id)))
673  (outedge)                             ; the FGN we jump/fall in to.
674                              ; true if outedge is next in emit order
675)
676
677(defun make-jumpnode (id)
678  (init-dll-header (%make-jumpnode id)))
679   
680;;; A node that ends in a conditional branch, followed by an implicit
681;;; or explicit jump.  Keep track of the conditional branch and the
682;;; node it targets.
683(defstruct (condnode (:include jumpnode)
684                     (:constructor %make-condnode (id)))
685                                        ; the FGN it targets
686  condbranch
687  branchedge
688)
689
690(defun make-condnode (id)
691  (init-dll-header (%make-condnode id)))
692
693
694;;; A node that ends with a CALL, followed by an implicit or explict jump.
695(defstruct (callnode (:include jumpnode)
696                     (:constructor %make-callnode (id mycall)))
697  mycall
698
699)
700                             
701(defun make-callnode (id mycall)
702  (init-dll-header (%make-callnode id mycall)))       
703
704;;; A node that terminates with a return i.e., a jump-return-pc or
705;;; jump-subprim.
706(defstruct (returnnode (:include fgn)
707                       (:constructor %make-returnnode (id)))
708)
709
710(defun make-returnnode (id)
711  (init-dll-header (%make-returnnode id)))
712
713
714(defun find-extended-block-bounds (fgn)
715  (let* ((first (do* ((first fgn pred)
716                      (pred (fgn-extended-pred first) (fgn-extended-pred first)))
717                     ((null pred) first)))
718         (last  (do* ((last fgn succ)
719                      (succ (fgn-extended-succ last) (fgn-extended-succ last)))
720                     ((null succ) last))))
721    (values (vinsn-sequence (dll-node-succ (dll-header-first first)))
722              (vinsn-sequence (dll-header-last last)))))
723         
724;;; Some specified attribute is true.
725(defun %vinsn-attribute-p (vinsn mask)
726  (declare (fixnum mask))
727  (if (vinsn-p vinsn)
728    (let* ((template (vinsn-template vinsn)))
729      (not (eql 0 (logand mask (the fixnum (vinsn-template-attributes template))))))))
730
731;;; All specified attributes are true.
732(defun %vinsn-attribute-= (vinsn mask)
733  (declare (fixnum mask))
734  (if (vinsn-p vinsn)
735    (let* ((template (vinsn-template vinsn)))
736      (= mask (the fixnum (logand mask (the fixnum (vinsn-template-attributes template))))))))
737 
738(defmacro vinsn-attribute-p (vinsn &rest attrs)
739  `(%vinsn-attribute-p ,vinsn ,(encode-vinsn-attributes attrs)))
740
741(defmacro vinsn-attribute-= (vinsn &rest attrs)
742  `(%vinsn-attribute-= ,vinsn ,(encode-vinsn-attributes attrs)))
743
744;;; Ensure that conditional branches that aren't followed by jumps are
745;;; followed by (jump lab-next) @lab-next.  Ensure that JUMPs and
746;;; JUMPLRs are followed by labels.  It's easiest to do this by
747;;; walking backwards.  When we're all done, labels will mark the
748;;; start of each block.
749
750(defun normalize-vinsns (header)
751  (do* ((prevtype :label currtype)
752        (current (dll-header-last header) (dll-node-pred current))
753        (currtype nil))
754       ((eq current header)
755        (unless (eq prevtype :label)
756          (insert-dll-node-after
757           (aref *backend-labels* (backend-get-next-label))
758           current))
759        (merge-adjacent-labels header))
760    (setq currtype (cond ((vinsn-label-p current) :label)
761                         ((vinsn-attribute-p current :branch) :branch)
762                         ((vinsn-attribute-p current :call) :call)
763                         ((vinsn-attribute-p current :jump) :jump)
764                         ((vinsn-attribute-p current :jumplr) :jumplr)))
765    (case currtype
766      ((:jump :jumplr)
767       (unless (eq prevtype :label)
768         (let* ((lab (aref *backend-labels* (backend-get-next-label))))
769           (insert-dll-node-after lab current))))
770      ((:branch :call)
771       (unless (eq prevtype :jump)
772         (let* ((lab
773                 (if (eq prevtype :label)
774                   (dll-node-succ current)
775                   (aref *backend-labels* (backend-get-next-label))))
776                (jump (select-vinsn "JUMP" *backend-vinsns* (list lab))))
777           (push jump (vinsn-label-refs lab))
778           (unless (eq prevtype :label)
779             (insert-dll-node-after lab current))
780           (insert-dll-node-after jump current))))
781      ((nil)
782       (if (eq prevtype :label)
783         (let* ((lab (dll-node-succ current)))
784           (when (vinsn-label-p lab)
785             (insert-dll-node-after
786              (let* ((jump (select-vinsn "JUMP" *backend-vinsns* (list lab))))
787
788                (push jump (vinsn-label-refs lab))
789                jump)
790              current))))))))
791
792
793;;; Unless the header is empty, remove the last vinsn and all preceding
794;;; vinsns up to and including the preceding label.  (Since the vinsns
795;;; have been normalized, there will always be a preceding label.)
796;;; Return the label and the last vinsn, or (values nil nil.)
797(defun remove-last-basic-block (vinsns)
798  (do* ((i 1 (1+ i))
799        (current (dll-header-last vinsns) (dll-node-pred current)))
800       ((eq current vinsns) (values nil nil))
801    (declare (fixnum i))
802    (when (vinsn-label-p current)
803      (assert (not (eql i 1) ))
804      (return (remove-dll-node current i)))))
805
806
807                             
808
809
810                         
811(defun compute-live-sets (fg header)
812  (let* ((regs (vinsn-list-lregs header))
813         (nregs (length regs)))
814    (declare (fixnum nregs)
815             (type (vector t) regs))
816    (dolist (block fg)
817      (setf (fgn-live-gen block) (make-array nregs :element-type 'bit)
818            (fgn-live-kill block) (make-array nregs :element-type 'bit)
819            (fgn-live-out block) (make-array nregs :element-type 'bit)
820            (fgn-live-in block)  (make-array nregs :element-type 'bit)))
821   
822    (dolist (block fg)
823      (do-dll-nodes (vinsn block)
824        (when (typep vinsn 'vinsn)
825          (let* ((template (vinsn-template vinsn))
826                 (vp (vinsn-variable-parts vinsn))
827                 (nres (length (vinsn-template-result-vreg-specs template)))
828                 (nargs (length (vinsn-template-argument-vreg-specs template)))
829                 (ntemps (length (vinsn-template-temp-vreg-specs template)))
830                 (nhybrids (vinsn-template-nhybrids template))
831                 (nntemps (- (the fixnum (+ nres nargs)) nhybrids))
832                 (nvp (+ nntemps ntemps))
833                 (gen (fgn-live-gen block))
834                 (kill (fgn-live-kill block)))
835            (declare (simple-vector vp) (fixnum nres nargs ntemps nntemps nvp nhybrids)
836                     (simple-bit-vector gen kill))
837            (do* ((i (the fixnum (- nres nhybrids)) (1+ i)))
838                 ((= i nntemps))
839              (declare (fixnum i))
840              (let* ((part (svref vp i)))
841                (when (typep part 'lreg)
842                  (let* ((id (lreg-id part)))
843                    (when (eql 0 (sbit kill id))
844                      (setf (sbit gen id) 1))))))
845            (dotimes (i nres)
846              (let* ((part (svref vp i)))
847                (when (typep part 'lreg)
848                  (setf (sbit kill (lreg-id part)) 1))))
849            (do* ((i nntemps (1+ i)))
850                 ((= i nvp))
851              (declare (fixnum i))
852              (let* ((part (svref vp i)))
853                (when (typep part 'lreg)
854                  (setf (sbit kill (lreg-id part)) 1))))))))
855    (let* ((rnodes (coerce (dfs-postorder fg) 'list))
856           (changed nil))
857      (assert (eql (length fg) (length rnodes)))
858      (loop
859        (setq changed nil)
860        (dolist (block rnodes)
861          (let* ((in (make-array nregs :element-type 'bit))
862                 (out (make-array nregs :element-type 'bit)))
863            (declare (dynamic-extent in out))
864            (when (typep block 'condnode)
865              (bit-ior out (fgn-live-in (branch-target-node (condnode-condbranch block))) out))
866            (when (typep block 'jumpnode)
867              (bit-ior out (fgn-live-in (jumpnode-outedge block)) out ))
868            (bit-andc2 in (fgn-live-kill block) in)
869            (bit-ior in (fgn-live-gen block) in)
870            (unless (equal out (fgn-live-out block))
871              (setq changed t)
872              (bit-boole boole-1 out out (fgn-live-out block)))
873            (unless (equal in (fgn-live-in block))
874              (setq changed t)
875              (bit-boole boole-1 in in (fgn-live-in block)))))
876        (unless changed   (return fg))))))
877
878
879;;; Create a flow graph from vinsns and return the entry node.
880(defun create-flow-graph (vinsns)
881
882  (let* ((nodes ()))
883   
884    (flet ((label->fgn (label) (dll-node-pred label)))
885      (loop
886        (multiple-value-bind (label last) (remove-last-basic-block vinsns)
887          (when (null label) (return))
888          (let* ((id (vinsn-label-id label))
889                 (node (if (vinsn-attribute-p last :jumpLR)
890                         (make-returnnode id)
891                         (let* ((pred (dll-node-pred last)))
892                           (if (vinsn-attribute-p pred :branch)
893                             (make-condnode id)
894                             (if (vinsn-attribute-p pred :call)
895                               (make-callnode id pred)
896                               (make-jumpnode id)))))))
897            (declare (fixnum id))
898            (insert-dll-node-after label node last)
899            (do-dll-nodes (v node) (if (vinsn-attribute-p v :call)
900                                     (push v (fgn-call-vinsns node))))
901            (push node nodes))))
902     
903      (dolist (node nodes)
904        (if (typep node 'jumpnode)
905          (let* ((jump (dll-header-last node))
906                 (jmptarget (branch-target-node jump)))
907            (setf (jumpnode-outedge node) jmptarget)
908            (pushnew node (fgn-inedges jmptarget))
909            (pushnew jmptarget (fgn-outedges node))
910            (if (typep node 'condnode)  ; a subtype of jumpnode
911              (let* ((branch (dll-node-pred jump))
912                     (branchtarget (branch-target-node branch)))
913                (setf (condnode-condbranch node) branch
914                      (condnode-branchedge node) branchtarget)
915               
916                (pushnew branchtarget (fgn-outedges node))
917                (pushnew node (fgn-inedges branchtarget)))))))
918      ;; Merge adjacent nodes where the first "falls into" the second
919      (do* ((nodes1 nodes (cdr nodes1))
920            (first (car nodes1) (car nodes1))
921            (second (cadr nodes1) (cadr nodes1)))
922           ((or (null first) (null second)) (setq nodes (delete nil nodes)))
923        (when (and (null (cdr (fgn-inedges second))) (eq first (car (fgn-inedges second)))
924                   (null (cdr (fgn-outedges first))) (eq second (car (fgn-outedges first))))
925          (setf (fgn-extended-pred second) first
926                (fgn-extended-succ first) second)
927                   
928
929
930          (unless (typep first 'callnode)
931            (dolist (ref (fgn-inedges first))
932              (nsubstitute second first (fgn-outedges ref))
933              (when (typep ref 'jumpnode)
934                (when (eq first (jumpnode-outedge ref))
935                  (setf (jumpnode-outedge ref) second))
936                (when (typep ref 'condnode)
937                  (when (eq first (condnode-branchedge ref))
938                    (setf (condnode-branchedge ref) second)))))
939
940            (if (setf (fgn-extended-pred second) (fgn-extended-pred first))
941              (setf (fgn-extended-succ (fgn-extended-pred first)) second))
942            (setf (fgn-inedges second) (fgn-inedges first))
943            (multiple-value-bind (label1 jump) (detach-dll-nodes first)
944              (let* ((label2 (dll-header-succ second)))
945                (insert-dll-node-before label1 label2 jump)
946                (when (null (delete jump (vinsn-label-refs label2)))
947                  (remove-dll-node label2))
948                (remove-dll-node jump)
949                (setf (fgn-id second) (fgn-id first))))
950         
951            (setf (car nodes1) nil))))
952
953
954
955     
956      (setf (vinsn-list-flow-graph vinsns) (refine-flow-graph nodes)))))
957
958(defun remove-block-vinsns (fgn)
959  (do-tail-dll-nodes (vinsn fgn) (elide-vinsn vinsn)))
960
961(defun refine-flow-graph (fg)
962  (dfs-walk fg)
963  (dolist (block fg) (unless (fgn-visited block) (remove-block-vinsns block)))
964  (remove-if-not #'fgn-visited fg))
965
966
967(defun linearize-flow-graph (fg header)
968  (do* ((head (car fg) (car tail))
969        (tail (cdr fg) (cdr tail)))
970       ((null head) header)
971    (multiple-value-bind (first last) (detach-dll-nodes head)
972      (when first
973        (insert-dll-node-before first header last)
974        (when (and (vinsn-attribute-p last :jump)
975                   (eq (car tail) (branch-target-node last)))
976          (let* ((lab (dll-node-succ (car tail))))
977            (when (null (setf (vinsn-label-refs lab)
978                              (delete last (vinsn-label-refs lab))))
979              (remove-dll-node lab)))
980          (elide-vinsn last))))))
981                   
982   
983                         
984(defun delete-unreferenced-labels (labels)
985  (delete #'(lambda (l)
986              (unless (vinsn-label-refs l)
987                (when (vinsn-label-succ l)
988                  (remove-dll-node l))
989                t)) labels :test #'funcall))
990
991(defun branch-target-node (v)
992  (check-type v vinsn)
993  (dll-node-pred (svref (vinsn-variable-parts v) 0)))
994
995(defun replace-label-refs (vinsn old-label new-label)
996  (let ((vp (vinsn-variable-parts vinsn)))
997    (dotimes (i (length vp))
998      (when (eq (svref vp i) old-label)
999        (setf (svref vp i) new-label)))))
1000 
1001;;; Try to remove jumps/branches to jumps.
1002(defun maximize-jumps (header)
1003  (do* ((prev nil next)
1004        (next (dll-header-first header) (dll-node-succ next)))
1005       ((eq next header))
1006    (when (and (vinsn-attribute-p next :jump)
1007               (vinsn-label-p  prev))
1008      (let* ((target (svref (vinsn-variable-parts next) 0)))
1009        (unless (eq target prev)
1010          (dolist (ref (vinsn-label-refs prev) (setf (vinsn-label-refs prev) nil))
1011            (replace-label-refs ref prev target)
1012            (push ref (vinsn-label-refs target))))))))
1013
1014(defparameter *nx-do-dead-code-elimination* t)
1015
1016
1017(defun eliminate-dead-code (header)
1018  (when *nx-do-dead-code-elimination*
1019    (let* ((eliding nil)
1020           (won nil))
1021      (do-dll-nodes (element header won)
1022        ;; If a label, leave it.
1023        (etypecase element
1024          (vinsn-label
1025           (when (typep (vinsn-label-id element) 'fixnum)
1026             (if (vinsn-label-refs element)
1027               (setq eliding nil))))
1028          (vinsn
1029           (when (vinsn-attribute-p element :align)
1030             (let* ((next (vinsn-succ element)))
1031               (when (and (typep next 'vinsn-label)
1032                          (typep (vinsn-label-id next) 'fixnum)
1033                          (not (null (vinsn-label-refs next))))
1034                 (setq eliding nil))))
1035           (cond (eliding
1036                  (setq won t)
1037                  (let* ((operands (vinsn-variable-parts element)))
1038                    (dotimes (i (length operands) (elide-vinsn element))
1039                      (let* ((op (svref operands i)))
1040                        (when (typep op 'vinsn-label)
1041                          (setf (vinsn-label-refs op)
1042                                (delete element (vinsn-label-refs op))))))))
1043                 (t (setq eliding (vinsn-attribute-p element :jump))))))))))
1044         
1045
1046(defvar *backend-use-linear-scan* nil)
1047
1048(define-condition linear-scan-bailout ()
1049  ())
1050
1051(defconstant interval-regtype-node 0)
1052(defconstant interval-regtype-imm 1)
1053(defconstant interval-regtype-float 2)
1054(defconstant interval-regtype-cr 3)
1055
1056(defstruct (interval (:include dll-node)
1057                     (:constructor make-interval (lreg begin end regtype preg)))
1058  lreg
1059  (begin 0)
1060  (end 0)
1061  (regtype 0)  (preg nll)
1062  (avail 0 :type fixnum)                             ; available regs before we assigned preg
1063  idx
1064  parent
1065  (spill-offset nil)
1066  (killed #() :type simple-vector)
1067  child
1068  (flags 0 :type fixnum)
1069  (use-positions () :type list) ; sequence numbers of lreg-refs and defs
1070  (active-before () :type list)
1071  (active-after () :type list)
1072  (trivial-def nil)
1073  (conflicts () :type list)
1074  (alt-preg 0 :type (unsigned-byte 4))
1075  (conflicts-with () :type list)
1076  (alive t)
1077  extension
1078)
1079
1080
1081
1082
1083(defmethod print-object ((i interval) stream)
1084  (print-unreadable-object (i stream :type t)
1085    (format stream "~c ~d:(~d) ~s ~s/~s ~s (~s)" (if (interval-trivial-def i) #\? #\space )(interval-idx i) (interval-flags i) (interval-lreg i) (interval-begin i) (interval-end i) (interval-regtype i) (interval-preg i))))
1086
1087
1088                   
1089
1090
1091
1092(defun registers-killed-by-call (vinsn masks)
1093    (declare (simple-vector masks) (ignorable vinsn))
1094  (let* ((nodes *backend-node-temps*)
1095         (imms  *backend-imm-temps*)
1096         (fprs *backend-fp-temps*)
1097         (crfs *backend-crf-temps*))
1098    (when (vinsn-attribute-p vinsn :subprim)
1099      (case (vinsn-template-name (vinsn-template vinsn))
1100
1101       
1102       
1103        ))
1104
1105    (setf (aref masks interval-regtype-node) nodes
1106          (aref masks  interval-regtype-imm) imms
1107          (aref masks interval-regtype-float) fprs
1108          (aref masks interval-regtype-cr) crfs)))
1109
1110(defun find-end-of-extended-call (seg call-vinsn)
1111  (declare (ignorable seg))
1112  ;; cheat
1113  (let* ((label (svref (vinsn-variable-parts call-vinsn) 0)))
1114    (vinsn-label-succ label)))
1115 
1116(defun extend-intervals-for-loops (seg)
1117  (let* ((fg (vinsn-list-flow-graph seg))
1118         (lregs (vinsn-list-lregs seg))
1119         (nregs (length lregs))
1120         (templates (backend-p2-vinsn-templates *target-backend*)))
1121    (declare (fixnum nregs) (type (vector t) lregs))
1122    (dolist (node fg)
1123      (let* ((live-in (fgn-live-in node)))
1124        (declare (simple-bit-vector live-in))
1125        (dotimes (i nregs)
1126          (when (eql 1 (sbit live-in i))
1127            (let* ((lreg (aref lregs i))
1128                   (interval (lreg-interval lreg))
1129                   (end (interval-end interval)))
1130              (unless (fixed-lreg-p lreg)
1131                (dolist (pred (fgn-inedges node))
1132                  (let* ((xfer ())
1133                         (ref-vinsn ()))
1134                 
1135                 
1136                    (when (and (typep pred 'condnode)
1137                               (eq node (condnode-branchedge pred))
1138                               (setq xfer (condnode-condbranch pred))
1139                               (>  (vinsn-sequence xfer) end))
1140                      (setq ref-vinsn (select-vinsn 'ref templates (list lreg))))
1141                   
1142                    (when (and (not xfer)
1143                               (eq node (jumpnode-outedge pred))
1144                               (setq xfer (dll-header-last pred))
1145                               (>  (vinsn-sequence xfer) end))
1146                      (setq ref-vinsn (select-vinsn 'ref templates (list lreg))) )
1147                    (when ref-vinsn
1148                      (insert-vinsn-before ref-vinsn xfer)
1149                      (let*  ((refpos (vinsn-sequence ref-vinsn)))
1150                        (setf (interval-use-positions interval)
1151                              (append (interval-use-positions interval) (list refpos))
1152                              (interval-end interval) refpos)))))))))))))
1153               
1154             
1155                       
1156                           
1157             
1158           
1159         
1160                 
1161(defun build-interval-list (seg)
1162  (let* ((list (vinsn-list-intervals seg)) 
1163         (fg (vinsn-list-flow-graph seg))
1164         (nregs (length (vinsn-list-lregs seg))))
1165    (declare (fixnum nregs))
1166                 
1167         
1168
1169    (dolist (block fg)
1170      (dolist (v (fgn-call-vinsns block))
1171        (unless (vinsn-attribute-p v :extended-call)
1172          (linear-scan-bailout 'call))
1173        (let* ((end-vinsn v)
1174               (start-vinsn end-vinsn)
1175               (low (1+ (vinsn-sequence start-vinsn)))
1176               (high low)
1177               (killed (make-array 4)))
1178          (declare (simple-vector killed) )
1179
1180          (when (vinsn-attribute-p v :extended-call)
1181            (setq high (vinsn-sequence (find-end-of-extended-call seg v))))
1182          (registers-killed-by-call v killed)
1183          (let* ((interval (make-interval nil low high nil nil)))
1184            (setf (interval-killed interval) killed)
1185            (vector-push-extend interval  list))
1186          )))
1187             
1188               
1189       
1190    (setf (vinsn-list-spill-area-used seg) (make-array nregs :element-type 'bit))
1191
1192    (dovector (lreg (vinsn-list-lregs seg))
1193      (let* ((refs (lreg-refs lreg))
1194             (defs (lreg-defs lreg)))
1195        (when (cdr refs)
1196          (setf (lreg-refs lreg) (sort refs #'< :key #'vinsn-sequence)))
1197        (when (cdr defs)
1198          (setf (lreg-defs lreg) (sort defs #'< :key #'vinsn-sequence))))
1199             
1200      (let* ((all (append (lreg-defs lreg) (lreg-refs lreg))))
1201       
1202        (when all
1203         
1204          (let* ((use-positions (sort (mapcar #'vinsn-sequence all) #'<))
1205                 (min (car use-positions))
1206                 (max (car (last use-positions)))
1207                 (class (lreg-class lreg))
1208                 (regtype (cond ((eql class hard-reg-class-fpr)
1209                                 interval-regtype-float)
1210                                ((eql class hard-reg-class-crf)
1211                                 interval-regtype-cr)
1212                                ((eql class hard-reg-class-gpr)
1213                                 (if (eql (lreg-mode lreg) hard-reg-class-gpr-mode-node)
1214                                   interval-regtype-node
1215                                   interval-regtype-imm)))))
1216           
1217            (let* ((interval (make-interval lreg min max regtype nil))
1218                   )
1219             
1220              (setf (lreg-interval lreg) interval)
1221              (setf (interval-use-positions interval)
1222                    use-positions)
1223              (when (logbitp lreg-pre-spill-bit (lreg-flags lreg))
1224                (assert (not (interval-parent interval)))
1225                (process-pre-spilled-interval seg interval lreg (lreg-spill-offset lreg)))
1226              (vector-push-extend
1227               interval
1228               list))))))
1229    (extend-intervals-for-loops seg)
1230    (let* ((max (vinsn-list-max-seq seg)))
1231      (vector-push-extend (make-interval  nil max max nil nil) list))
1232                   
1233                   
1234                   
1235
1236                         
1237    (setf (vinsn-list-intervals seg)
1238
1239          (sort list (lambda (x y)
1240                       (let* ((beginx (interval-begin x))
1241                              (beginy (interval-begin y)))
1242                         (or (< beginx beginy)
1243                             (and (= beginx beginy)
1244                                  (or (null (interval-lreg x))
1245                                      (lreg-local-p (interval-lreg x)))))))))))
1246
1247
1248
1249(defun spill-vinsn-for-interval (interval)
1250  (let* ((regtype (interval-regtype interval)))
1251    (if (eql regtype interval-regtype-node)
1252      'spill
1253      (if (eql regtype interval-regtype-imm)
1254        'spill-natural
1255        (if (eql regtype interval-regtype-float)
1256          (case (fpr-mode-value-name (get-regspec-mode (interval-lreg interval)))
1257            (:double-float 'spill-double-float)
1258            (:single-float 'spill-single-float)
1259            (:complex-double-float 'spill-complex-double-float)
1260            (:complex-single-float 'spill-complex-single-float)))))))
1261 
1262
1263(defun reload-vinsn-for-interval (interval)
1264  (let* ((regtype (interval-regtype interval)))
1265    (if (eql regtype interval-regtype-node)
1266      'reload
1267      (if (eql regtype interval-regtype-imm)
1268        'reload-natural
1269        (if (eql regtype interval-regtype-float)
1270          (case (fpr-mode-value-name (get-regspec-mode (interval-lreg interval)))
1271            (:double-float 'reload-double-float)
1272            (:single-float 'reload-single-float)
1273            (:complex-double-float 'reload-complex-double-float)
1274            (:complex-single-float 'reload-complex-single-float)))))))
1275         
1276
1277(defun insert-vinsn-before (vinsn target)
1278  (let* ((target-seq (vinsn-sequence target))
1279         (pred-seq (1- target-seq))
1280         (pred (vinsn-pred target))
1281         (target-fgn (vinsn-fgn target)))
1282    (declare (fixnum target-seq pred-seq))
1283    (if (and (typep pred 'vinsn)
1284             (eql (vinsn-sequence pred) pred-seq))
1285      (insert-vinsn-before vinsn pred)
1286      (progn
1287        (insert-dll-node-before vinsn target)
1288        (setf (vinsn-sequence vinsn) pred-seq
1289             (vinsn-fgn vinsn) target-fgn)))))
1290
1291(defun insert-vinsn-after (vinsn target)
1292  (let* ((target-seq (vinsn-sequence target))
1293         (succ-seq (1+ target-seq))
1294         (succ (vinsn-succ target))
1295         (target-fgn (vinsn-fgn target)))
1296    (declare (fixnum target-seq succ-seq))
1297    (if (and (typep succ 'vinsn)
1298             (eql (vinsn-sequence succ) succ-seq))
1299      (insert-vinsn-after vinsn succ)
1300      (progn
1301        (insert-dll-node-after vinsn target)
1302        (setf (vinsn-sequence vinsn) succ-seq
1303              (vinsn-fgn vinsn) target-fgn)))))
1304
1305(defun note-reload (interval ref)
1306  (let* ((node (vinsn-fgn ref))
1307         (reloads (fgn-reloads node))
1308         (already (assoc interval reloads)))
1309    (if already
1310      (pushnew ref (cdr already))
1311      (push (cons interval (list ref)) (fgn-reloads node)))))     
1312
1313(defun note-spill (interval  def)
1314  (let* ((node (vinsn-fgn def))
1315         (spills (fgn-spills node))
1316         (already (assoc interval spills)))
1317    (if already
1318      (pushnew def (cdr already))
1319      (push (cons interval (list def))  (fgn-spills node)))))
1320         
1321
1322
1323         
1324;;; treat incoming stack arguments as if they had
1325;;; been spilled to the stack.
1326(defun process-pre-spilled-interval (seg interval lreg offset)
1327  (linear-scan-bailout 'pre-spilled-interval)
1328  (setf (interval-lreg interval) lreg
1329        (interval-spill-offset interval) offset)
1330  (let* ((used (vinsn-list-spill-area-used seg))
1331        (id (lreg-id lreg)))
1332    (setf (sbit used id) 1))
1333  (let* ((next-offset (1+ offset)))
1334    (when (> next-offset (vinsn-list-spill-base seg))
1335      (setf (vinsn-list-spill-base seg) next-offset))
1336    (setf (interval-flags interval) interval-flag-pre-spilled)
1337   
1338
1339    '(dolist (ref (lreg-refs lreg))
1340      (note-reload interval ref)
1341      )
1342    '(dolist (def (lreg-defs lreg))
1343      (note-spill interval def)
1344      )))
1345                 
1346
1347(defun spill-offset-for-interval (seg interval)
1348  (let* ((used (vinsn-list-spill-area-used seg))
1349         (base (vinsn-list-spill-base seg))
1350         (nregs (length (vinsn-list-lregs seg))))
1351    (or (interval-spill-offset interval)
1352        (setf (interval-spill-offset interval)
1353              (if (eql (interval-regtype interval) interval-regtype-node)
1354                (dotimes (i nregs)
1355                  (when (eql 0 (sbit used i))
1356                    (setf (sbit used i) 1)
1357                    (incf (vinsn-list-spill-depth seg))
1358                    (when (> (vinsn-list-spill-depth seg)
1359                             (vinsn-list-max-spill-depth seg))
1360                      (setf  (vinsn-list-max-spill-depth seg)
1361                             (vinsn-list-spill-depth seg)))
1362                    (return (+ i base))))
1363                (prog1 (vinsn-list-nfp-spill-offset seg)
1364                  (incf (vinsn-list-nfp-spill-offset seg) 16)
1365                  (when (> (vinsn-list-nfp-spill-offset seg)
1366                           (vinsn-list-max-nfp-spill-depth seg))
1367                    (setf (vinsn-list-max-nfp-spill-depth seg)
1368                          (vinsn-list-nfp-spill-offset seg))))))))) 
1369
1370
1371(defun interval-containing-vinsn (interval vinsn)
1372  (let* ((seq (vinsn-sequence vinsn)))
1373    (if (and (>= seq (interval-begin interval))
1374             (<= seq (interval-end interval)))
1375      interval
1376      (let* ((child (interval-child interval)))
1377        (if child (interval-containing-vinsn child vinsn))))))
1378
1379         
1380         
1381;;; Return the first use of INTERVAL within BLOCK and the spanning interval
1382(defun first-use-of-interval-in-block (seg interval block)
1383  (multiple-value-bind (start end) (find-extended-block-bounds block)
1384    (declare (fixnum start end))
1385    (do* ((i interval (interval-child i)))
1386         ((null i) (values nil nil))
1387      (dolist (use (interval-use-positions i))
1388        (declare (fixnum use))
1389        (if (and (>= use start)
1390                 (< use end))
1391          (return-from first-use-of-interval-in-block (values i (find-vinsn seg use))))))))
1392
1393;; Harder
1394(defun last-use-of-interval-in-block (seg interval block)
1395  (multiple-value-bind (start end) (find-extended-block-bounds block)
1396    (declare (fixnum start end))
1397    (let* ((child nil)
1398           (last-use))
1399      (do* ((i interval (interval-child i)))
1400           ((null i) (values child (if last-use (find-vinsn seg last-use))))
1401        (dolist (use (interval-use-positions i))
1402          (declare (fixnum use))
1403          (if (and (>= use start)
1404                   (< use end))
1405            (setq child i last-use use)))))))
1406 
1407         
1408   
1409(defun end-of-fgn-containing (vinsn)
1410  (let* ((fgn (vinsn-fgn vinsn)))
1411    (vinsn-sequence (dll-header-last fgn))))
1412
1413(defparameter *bailout-on-spill* t)
1414
1415(defun spill-and-split-interval (seg why parent new-end vector list)
1416  (when *bailout-on-spill*
1417    (linear-scan-bailout why))
1418
1419  (let* ((lreg (interval-lreg parent)))
1420    (assert lreg () "no lreg for interval ~s" parent)
1421   
1422    (let* ((used (vinsn-list-spill-area-used seg))
1423           (base (vinsn-list-spill-base seg)))
1424      (declare (simple-bit-vector used)
1425               (fixnum base))
1426      (let* ((nregs (length (vinsn-list-lregs seg))))
1427        (declare (fixnum nregs))
1428        (let* ((offset (or (interval-spill-offset parent)
1429                           (setf (interval-spill-offset parent) 
1430                                 (if (eql (interval-regtype parent) interval-regtype-node)
1431                                   (dotimes (i nregs)
1432                                     (when (eql 0 (sbit used i))
1433                                       (setf (sbit used i) 1)
1434                                       (incf (vinsn-list-spill-depth seg))
1435                                       (when (> (vinsn-list-spill-depth seg)
1436                                                (vinsn-list-max-spill-depth seg))
1437                                         (setf  (vinsn-list-max-spill-depth seg)
1438                                                (vinsn-list-spill-depth seg)))
1439                                       (return (+ i base))))
1440                                   (prog1 (vinsn-list-nfp-spill-offset seg)
1441                                     (incf (vinsn-list-nfp-spill-offset seg) 16)
1442                                     (when (> (vinsn-list-nfp-spill-offset seg)
1443                                              (vinsn-list-max-nfp-spill-depth seg))
1444                                       (setf (vinsn-list-max-nfp-spill-depth seg)
1445                                             (vinsn-list-nfp-spill-offset seg))))))))
1446               (child-used (member-if (lambda (pos) (> pos new-end)) (interval-use-positions parent)))
1447               (ncu (length child-used)))
1448          '(let* ((defs (lreg-defs lreg)))
1449           (when (cdr defs)  (linear-scan-bailout (format nil "not yet - assignment/multiple definitions in spilled interval ~s" defs))))
1450         
1451
1452          (let* ((min (car child-used))
1453                 (max (car (last child-used))))
1454            (let* ((child (make-interval  lreg min max (interval-regtype parent) nil  )))
1455              (setf (interval-parent child) parent
1456                    (interval-child parent) child
1457                    (interval-spill-offset child) offset
1458                    (interval-flags child) (interval-flags parent)
1459                    (interval-use-positions child) child-used
1460                    (interval-use-positions parent) (butlast (interval-use-positions parent) ncu))
1461              (do-dll-nodes (r list (error "no next interval"))
1462                (when (> (interval-begin r) min)
1463                  (insert-dll-node-before child r)
1464                  (rebuild-interval-vector seg vector  child r)   
1465                  (return)))
1466               
1467
1468
1469              ;; Ready to expire
1470              (setf (interval-end parent) (car (last (interval-use-positions parent)))))))))))
1471
1472(defun assign-interval-indices (vector)
1473  (declare (type (vector t) vector))
1474  (dotimes (i (length vector))
1475    (setf (interval-idx (aref vector i)) i)))
1476
1477(defun rebuild-interval-vector (seg vector new-element succ)
1478  (declare (type (vector t) vector))
1479  (let* ((idx (interval-idx succ)))
1480    (declare (fixnum idx) (ignorable idx))
1481    (let* ((n (length vector)))
1482      (declare (Fixnum n) (ignorable n))
1483      (progn
1484      (vector-push-extend new-element vector)
1485      (setf (vinsn-list-intervals seg)
1486      (stable-sort vector (lambda (x y)
1487                       (let* ((beginx (interval-begin x))
1488                              (beginy (interval-begin y)))
1489                         (or (< beginx beginy)
1490                             (and (= beginx beginy)
1491                                  (or (null (interval-lreg x))
1492                                      (lreg-local-p (interval-lreg x))))))))))
1493      #+no
1494      (progn
1495      (vector-push-extend nil vector)   ; make room
1496     
1497      (do* ((j n (1- j))
1498            (i (1- j) (1- i)))
1499           ((= j idx)
1500            (setf (aref vector idx) new-element)
1501)
1502
1503        (declare (fixnum i j))
1504                               
1505        (setf (aref vector j) (aref vector i))
1506        ))
1507      (assign-interval-indices vector)
1508      )))
1509           
1510
1511(defun replace-vinsn-operands (vinsn old new start end)
1512  (declare (fixnum start end))
1513  (let* ((seq (vinsn-sequence vinsn)))
1514    (declare (fixnum seq))
1515    (unless (or (< seq start) (> seq end))
1516      (let* ((v (vinsn-variable-parts vinsn)))
1517        (declare (simple-vector v))
1518        (dotimes (i (length v))
1519          (when (eq old (svref v i))
1520            (setf (svref v i) new)))))))
1521
1522
1523(defun expire-interval (seg interval)
1524  (let* ((avail (vinsn-list-available-physical-registers seg))
1525         (used (vinsn-list-spill-area-used seg))
1526         (preg (interval-preg interval)))
1527    (declare (simple-vector avail) (simple-bit-vector used) (ignorable used))
1528    (flet ((unuse-reg (regno type)
1529             ;;(ls-format "~&unuse ~d/~d for ~s" regno type interval)
1530             (setf (svref avail type)
1531                   (logior (svref avail type) (ash 1 regno)))
1532))
1533
1534      (when preg
1535        (unuse-reg preg (interval-regtype interval))))
1536    ;; we have to retain the (shared) spill slot until the last
1537    ;; child expires.
1538    )
1539  (postprocess-interval interval)
1540  )
1541       
1542(defun postprocess-interval (interval)
1543  (let*  ((lreg (interval-lreg interval))
1544          (preg (interval-preg interval))
1545          (start (interval-begin interval))
1546          (end (interval-end interval)))
1547    (declare (ignorable start end))
1548    (when lreg
1549      (let* ((defs (lreg-defs lreg)))
1550        (when (and defs (null (cdr defs)) (vinsn-attribute-p (car defs) :trivial-copy))
1551          (setf (interval-trivial-def interval) (car defs)))))
1552    (when (and lreg preg)
1553      (if (eql 0 (interval-flags interval))
1554        (setf (lreg-value lreg) preg)
1555        (progn
1556          (dolist (def (lreg-defs lreg))
1557            (replace-vinsn-operands def lreg preg start end))
1558          (dolist (ref (lreg-refs lreg))
1559            (replace-vinsn-operands ref lreg preg start end)))))))
1560
1561                       
1562                       
1563 
1564;;; try to pick an interval whose next use is farthest away.
1565(defun find-spill-candidate (intervals regtype  at)
1566  (let* ((max at) (best nil))
1567    (do-dll-nodes (interval intervals (or best (progn (ls-break)(linear-scan-bailout 'missing-interval))))
1568      (let* ((lreg (interval-lreg interval)))
1569        (unless (or (fixed-lreg-p lreg) (not (eql regtype (interval-regtype interval))))
1570          (let*  ((nextuse (member-if  (lambda (x) (> x at)) (interval-use-positions interval))))
1571            (when (and nextuse (> (car nextuse) max))
1572              (setq max (car nextuse) best interval))))))
1573    best))
1574       
1575
1576
1577
1578
1579(defun linear-scan (seg )
1580  (let* ((avail (vinsn-list-available-physical-registers seg)))
1581    (flet ((use-reg (regno type i)
1582             (declare (ignorable i))t
1583             ;;(ls-format "~& using ~s/~d in ~s" regno type i)
1584             (setf (svref avail type)
1585                   (logandc2 (svref avail type) (ash 1 regno))))
1586
1587           (select-available-register (mask)
1588             (declare (type (unsigned-byte 16) mask))
1589             (unless (eql 0 mask)
1590               (do* ((i 0 (1+ i)))
1591                    ((> i 15))
1592                 (when (logbitp i mask) (return i)))))
1593           (select-available-register-high (mask)
1594             (declare (type (unsigned-byte 16) mask))
1595             (unless (eql 0 mask)
1596               (do* ((i 15 (1- i)))
1597                    ((< i 0))
1598                 (when (logbitp i mask) (return i))))))
1599     
1600      (let* ((intervals (vinsn-list-intervals seg)))
1601        (declare (type (vector t) intervals))
1602        (let* ((active (make-dll-header))
1603               (unhandled (make-dll-header))
1604               ;;(expired (make-dll-header))
1605               (limit (vinsn-list-max-seq seg)))
1606          (assign-interval-indices intervals)
1607          (dotimes (i (length intervals))
1608            (let*  ((interval (aref intervals i)))
1609              (append-dll-node interval unhandled)))
1610          (do* ((i (pop-dll-node unhandled) (pop-dll-node unhandled))
1611                (begin (if i (interval-begin I) limit) (if i (interval-begin I) limit)))
1612               ((= begin limit) (progn (do-dll-nodes (a active ) (expire-interval seg a )) t   ))
1613
1614
1615
1616            (do-dll-nodes (other active)
1617              (let* ((other-end (interval-end other)))
1618                (when (< other-end begin)
1619                  (remove-dll-node other)
1620                  (expire-interval seg other ))))
1621
1622           
1623            (if (null (interval-lreg i))
1624              (let* ((caller-save ())
1625                     )
1626                (do-dll-nodes (a active)
1627                  (when (>= (interval-end a) (interval-end i))
1628                    ;; should see if preg is in the killed set
1629                    (push a caller-save)))
1630                (ls-note "caller-save = ~s call @ ~s" caller-save begin)
1631                (dolist (cs caller-save)
1632                  (spill-and-split-interval    seg 'call cs begin intervals unhandled)
1633                  )
1634                 
1635                         
1636                )
1637              (progn
1638                (do-dll-nodes (live active)
1639                  (when (eql (interval-regtype i) (interval-regtype live))
1640                    (push live (interval-active-before i))
1641                    (push i (interval-active-after live))))
1642              (let* ((regtype (interval-regtype i))
1643                     (mask (svref avail regtype))
1644                     (idx (interval-idx i)))
1645                (setf (interval-avail i) mask)
1646                (when (eql 0 mask)
1647                  (let* ((victim (find-spill-candidate active regtype begin)))
1648                    (progn (spill-and-split-interval   seg 'pressure victim begin intervals unhandled) (expire-interval seg victim ) (setq mask (svref avail regtype)) (assert (not (eql mask 0)) ()  "mask is still 0 after spilling ~s" victim))))
1649                                 
1650
1651
1652                (let* ((lreg (interval-lreg i))
1653                       (regtype (interval-regtype i))
1654                       (mask (svref avail regtype)))
1655                  (let* ((fixed (interval-preg i))
1656                         (targeted (and lreg (or (lreg-wired lreg) (lreg-local-p lreg)) (lreg-value lreg)))
1657                         (preg (or fixed (if (and targeted (logbitp targeted mask))
1658                                           targeted
1659                                           (select-available-register-high mask)))))
1660
1661
1662
1663                    (when (and fixed (not (logbitp fixed mask)))
1664                      (let* ((other (do-dll-nodes (x active (error "can't find interval with ~d" fixed))
1665                                      (when (and (eql regtype (interval-regtype x))
1666                                                 (eql fixed (interval-preg x))
1667                                                 (interval-lreg x))
1668                                     
1669                                        (return x)))))
1670                        (spill-and-split-interval seg 'conflict other begin intervals unhandled)))
1671
1672                    (when (and targeted (not (eql targeted preg)))
1673
1674                      (let*  ((rival (do-dll-nodes (other active (error "can't find rival on active-list"))
1675                                       (when (and (eql (interval-preg other) targeted)
1676                                                  (eql (interval-regtype other) regtype)
1677                                                  )
1678                                         (return other))))
1679                              (rival-lreg (and rival (interval-lreg rival)))
1680                              )
1681
1682                                       
1683                        (when (> (interval-idx rival) idx) (ls-break "???"))
1684                        (ls-format "~&want to use reg ~d, for ~s in use by ~s. ~d may be free" targeted lreg rival-lreg preg)
1685                        (cond ((null rival-lreg) (ls-break "no lreg for conflicting interval ~s" rival))
1686                              ((or (lreg-wired rival-lreg) (lreg-local-p rival-lreg))
1687                               (if (or (and (lreg-wired lreg)
1688                                            (lreg-wired rival-lreg))
1689                                       (eql (interval-end rival) begin)
1690                                       (null (lreg-refs rival-lreg))
1691                                       (null (lreg-refs lreg)))
1692                                 (setq preg targeted)
1693                                 (error "conflicting intervals overlap")))
1694
1695                              ((eql (interval-end rival) begin)
1696                               (setq preg targeted))
1697                              (rival
1698                               (when (or (lreg-wired rival-lreg)
1699                                         (lreg-local-p rival-lreg))
1700                                 (ls-break "bad idea"))
1701                               (do* ((rival-idx (interval-idx rival) (1+ rival-idx))
1702                                     (q rival (aref intervals rival-idx))
1703                                     (rival-avail (interval-avail q) (logand rival-avail (if (eql regtype (interval-regtype q)) (interval-avail q) -1))))
1704                                    ((= rival-idx idx)
1705                                     (if (eql rival-avail 0)
1706                                       ;; we made an unfortunate choice when we
1707                                       ;; assigned rhe register we want now  to
1708                                       ;; the rival interval, and can't back out
1709                                       ;; of that choice.  copy the rival's
1710                                       ;; preg to something that is now free and
1711                                       ;; split the rival.
1712                                       (progn
1713
1714
1715                                         (spill-and-split-interval seg 'conflict2 rival begin intervals unhandled))
1716                                       (let*  ((other-preg (select-available-register-high rival-avail)))
1717                                         ;;(ls-format "should have used ~d" other-preg)
1718                                         (use-reg other-preg regtype rival)
1719                                     
1720                                         (setf (interval-preg rival) other-preg)
1721                                         (do* ((qidx (1+ (interval-idx rival)) (1+ qidx)))
1722                                              ((= qidx idx)
1723                                               (setf (svref avail regtype)
1724                                                     (logior (svref avail regtype)
1725                                                             (ash 1 targeted))))
1726                                           (let* ((q (aref intervals qidx)))
1727                                             (when (eql (interval-regtype q) regtype)
1728                                               (setf (interval-avail q)
1729                                                     (logandc2 (interval-avail q)
1730                                                               (ash 1 other-preg)))))))))
1731                                 (setq preg targeted))))))
1732
1733
1734                    (use-reg preg regtype i)
1735                    (setf (interval-preg i) preg)
1736                    (append-dll-node i active))))))))))))
1737
1738;;; we don't need to do nearly as much of this as we have been doing.
1739(defun process-spills-and-reloads (fg)
1740  (let* ((templates (backend-p2-vinsn-templates *target-backend*)))
1741    (dolist (node fg)
1742      (let* ((spills (fgn-spills node))
1743             (reloads (fgn-reloads node)))
1744        (dolist (s spills)
1745          (destructuring-bind (i . defs) s
1746            (dolist (def defs)
1747              (let* ((preg (interval-preg i))
1748                     (offset (interval-spill-offset i))
1749                     (spill-vinsn (select-vinsn (spill-vinsn-for-interval i) templates (list preg offset))))
1750                (insert-vinsn-after spill-vinsn def)))))
1751        (dolist (r reloads)
1752          (destructuring-bind (i . refs) r
1753            (dolist (ref refs)
1754
1755              (let* ((preg (interval-preg i))
1756                     (offset (interval-spill-offset i))
1757                     (reload-vinsn (select-vinsn (reload-vinsn-for-interval i) templates (list preg offset))))
1758                (insert-vinsn-before reload-vinsn ref)))))))))
1759
1760 
1761
1762(defun resolve-split-intervals (seg)
1763  (let* (
1764         (lregs (vinsn-list-lregs seg))
1765         (nregs (length lregs)))
1766
1767               
1768    (dovector (lreg lregs )
1769      (let* ((interval (lreg-interval lreg))
1770             (offset (if interval (interval-spill-offset interval))))
1771       (when offset
1772         (dolist (use (interval-use-positions interval))
1773o           (unless (and (eql use (interval-begin interval))
1774                        (null (interval-parent interval)))
1775             (let* ((vinsn (find-vinsn seg use)))
1776               (when (memq vinsn (lreg-defs lreg))
1777                 (note-spill interval vinsn)))))
1778         (do* ((child (interval-child interval) (interval-child child)))
1779              ((null child))
1780           (dolist (use (interval-use-positions child))
1781             (let* ((def (find-vinsn seg use)))
1782               (when (memq def (lreg-defs lreg))
1783                 (note-spill child def)))))
1784         
1785         (if (eql 0 (interval-flags interval))
1786          (do* ((child (interval-child interval) (interval-child child)))
1787               ((null child))
1788            (let* ((parent (interval-parent child))
1789
1790                   (parent-end-vinsn (find-vinsn seg (interval-end parent)))
1791                   (child-start-vinsn (find-vinsn seg (interval-begin child))))
1792              (note-reload child child-start-vinsn)
1793              (note-spill parent parent-end-vinsn)))
1794           (let* ((family ())
1795                  (lreg (interval-lreg interval)))
1796             (push interval family)
1797             (do* ((child (interval-child interval) (interval-child child)))
1798                  ((null child))
1799               (push child family))
1800             (dolist (x family)
1801               (dolist (use (interval-use-positions x))
1802                 (let* ((v (find-vinsn seg use)))
1803                   (when (memq v (lreg-refs lreg))
1804                   (note-reload x v)))))
1805           )))))
1806
1807   
1808    (dolist (from (vinsn-list-flow-graph seg))
1809      (dolist (to (fgn-outedges from))
1810        (unless (eq to (fgn-extended-succ from))
1811
1812          (let* ((live-in (fgn-live-in to)))
1813            (declare (simple-bit-vector live-in))
1814            (dotimes (i nregs)
1815              (when (= (sbit live-in i) 1)
1816                (let* ((interval (lreg-interval (aref lregs i)))
1817                       (offset (interval-spill-offset interval)))
1818                     
1819                  (when offset
1820
1821                    (multiple-value-bind (to-interval to-vinsn)
1822                        (first-use-of-interval-in-block seg interval to)
1823                      (multiple-value-bind (from-interval from-vinsn)
1824                          (last-use-of-interval-in-block seg interval from)
1825
1826                        (when (not (eq from-interval to-interval))
1827                          (when from-vinsn (note-spill from-interval from-vinsn))
1828                          (when to-vinsn(note-reload to-interval to-vinsn)))))))))))))))
1829                             
1830                         
1831                           
1832                       
1833           
1834                   
1835                 
1836           
1837(defstatic *linear-scan-won* 0)
1838(defstatic *linear-scan-lost* 0)
1839(defparameter *report-linear-scan-success* nil)
1840(defvar *bailout-reasons* (make-hash-table :test 'eq))
1841(defvar *bailout-lock* (make-lock))
1842
1843
1844
1845(defun linear-scan-bailout (reason)
1846  (when *backend-use-linear-scan*
1847    (when *report-linear-scan-success*
1848      (format *error-output* "~%~%bailing-out of linear-scan for ~a :~&~&~a" *current-function-name* reason ))
1849    (let* ((reasons *bailout-reasons*))
1850      (with-lock-grabbed (*bailout-lock*)
1851        (when (and reason (typep reason 'symbol))
1852          (let* ((count (gethash reason reasons 0)))
1853            (declare (fixnum count))
1854            (setf (gethash reason reasons) (the fixnum (1+ count))))
1855          )
1856        (incf *linear-scan-lost*)
1857    (signal 'linear-scan-bailout)))))
1858
1859
1860;;; This is not "unsafe".  it may affect debugging and error
1861;;;  reporting, but so do other things in the new backend, and
1862;;; we have already decided that those things (reducing stack
1863;; access) are important.
1864(defun try-to-omit-frame-pointer (seg)
1865  (declare (ignorable seg))
1866  #+x86-target
1867  (when t
1868    (let* ((uses ()))
1869      (when
1870          (do-dll-nodes (v seg t)
1871            (when (vinsn-attribute-p v :needs-frame-pointer)
1872              (return nil))
1873            (if (vinsn-attribute-p v :uses-frame-pointer)
1874              (push v uses)))
1875        (dolist (v uses t) (elide-vinsn v))))))
1876
1877(defun merge-adjacent-labels (header)
1878 
1879  (let* ((labels (collect ((labs)) 
1880                   (do-dll-nodes (v header)
1881                     (when (vinsn-label-p v) (labs v)))
1882                   (labs))))
1883    (do* ((repeat t))
1884         ((not repeat))
1885      (setq repeat nil 
1886            labels (delete-unreferenced-labels labels))
1887      (dolist (l labels)
1888        (let* ((succ (vinsn-label-succ l)))
1889          (when (vinsn-label-p succ)
1890            (backend-merge-labels l succ)
1891            (setq repeat t)
1892            (return)))))))
1893
1894
1895
1896;;; Intervals X and Y overlap if X begins before Y ends
1897;;; and X ends after Y begins.  If two intervals overlap,
1898;;; they can't use the same physical register.
1899;;; "intervals" is a vector ordered by start address. and we
1900;;; might be able to avoid linear search here by doing
1901;;; two binary searches of two ordered vectors.
1902(defun find-conflicting-intervals (interval preg)
1903  (declare (type (unsigned-byte 4) preg))
1904  (let* ((conflicts ()))
1905    (dolist (after (interval-active-after interval) conflicts)
1906      (when (and (interval-lreg after) (eql preg (interval-preg after)))
1907        (push after conflicts)))))
1908
1909(defun use-preg-in-interval (preg interval)
1910  (declare (type (unsigned-byte 4) preg))
1911  (let* ((mask (ash 1 preg)))
1912    (declare (fixnum mask))
1913    (dolist (after (interval-active-after interval))
1914      (when (interval-lreg after)
1915        (setf (interval-avail after)
1916              (logandc2 (interval-avail after) mask))))
1917    (setf (interval-preg interval) preg)))
1918
1919(defun unuse-preg-in-interval (preg interval)
1920  (declare (type (unsigned-byte 4) preg))
1921  (let* ((mask (ash 1 preg)))
1922    (declare (fixnum mask))
1923    (dolist (after (interval-active-after interval))
1924      (when (interval-lreg after)
1925        (setf (interval-avail after)
1926              (logior(interval-avail after) mask))))
1927    ))
1928
1929(defun other-pregs-for-conflicting-interval (i other-mask)
1930  (declare (fixnum other-mask))
1931  (let* ((mask (interval-avail i)))
1932    (declare (fixnum mask))
1933    (dolist (after (interval-active-after i) (logandc2 mask other-mask))
1934      (when (interval-lreg after)
1935        (setq mask (logand mask (interval-avail after)))))))
1936
1937
1938(defun pregs-used-before (interval)
1939  (let* ((mask 0))
1940    (declare (fixnum mask))
1941    (dolist (before (interval-active-before interval) mask)
1942      (when (interval-lreg before)
1943        (let* ((preg (interval-preg before)))
1944          (setq mask (logior (ash 1 preg) mask)))))))
1945
1946 
1947
1948(defun rebuild-avail-before (seg)
1949  (let* ((intervals (vinsn-list-intervals seg)))
1950    (declare (type (vector t) intervals))
1951    (dovector (i intervals)
1952      (when (interval-lreg i)
1953         
1954        (let* ((avail (svref (vinsn-list-available-physical-registers seg) (interval-regtype i)))
1955               (used (pregs-used-before i)))
1956          (declare (fixnum avail used))
1957          (setf (interval-avail i) (logandc2 avail used)))))))
1958
1959(defun fixed-lreg-p (x)
1960  (if (typep x 'lreg)
1961    (or (lreg-wired x) (lreg-local-p x))
1962    (report-bad-arg x 'lreg)))
1963
1964(defun fixed-interval-p (i)
1965  (fixed-lreg-p (interval-lreg i)))
1966
1967
1968(defun check-intervals (seg)
1969  (let* ((intervals (vinsn-list-intervals seg)))
1970    (declare (type (vector t) intervals))
1971    (dovector (i intervals t)
1972      (when (interval-lreg i)
1973        (when (find-conflicting-intervals i (interval-preg i))
1974          (ls-break i)
1975          (return nil))))))
1976
1977
1978(defun resolve-non-trivial-interval-conflicts (seg)
1979  (let* ((intervals (vinsn-list-intervals seg)))
1980    (declare (type (vector t) intervals))
1981    (dovector (i intervals)
1982      (let* ((lreg (interval-lreg i)))
1983      (when (and lreg (not (fixed-lreg-p lreg)))
1984
1985        (unless (interval-trivial-def i)
1986          (dolist (other (find-conflicting-intervals i (interval-preg i)))
1987            (let* ((tdef (interval-trivial-def other)))
1988              (if tdef
1989                (unless (eq lreg (trivial-copy-source-operand tdef))
1990                  (pushnew other (interval-conflicts-with i)))
1991                ;;(break "2??")
1992                )))
1993               
1994          (let ((cw (interval-conflicts-with i)))
1995            (when cw 
1996               ;;(break)
1997              (dolist (other cw)
1998                (setf (interval-conflicts other) (delete i (interval-conflicts other)))
1999                )
2000              ;;(break)
2001              (resolve-interval-conflict i nil)
2002              ))))))))
2003
2004
2005(defun trivial-copy-source-operand (v)
2006  (and (vinsn-attribute-p v :trivial-copy)
2007       (svref (vinsn-variable-parts v) 1)))
2008
2009;;; Choose another physical register for interval
2010               
2011(defun resolve-interval-conflict (interval reg)
2012  (let* ((lreg (interval-lreg interval)))
2013    (when lreg
2014      (if (or (lreg-wired lreg) (lreg-local-p lreg))
2015        (let*  ((tdef (interval-trivial-def interval)))
2016          (and tdef (eq reg (svref (vinsn-variable-parts tdef) 1))))
2017             
2018        (let* ((mask 0))
2019          (declare (fixnum mask))
2020          (dolist (other (interval-conflicts-with interval))
2021            (setq mask (logior mask (ash 1 (interval-preg other)))))
2022          (block resolve
2023            (let* ((avail (logandc2 (interval-avail interval) mask)))
2024              (declare (fixnum avail))
2025              (do* (( i 16 (1- i)))
2026                   ((< i 0) (ls-break "???")(linear-scan-bailout 'pressure))
2027                (declare (fixnum i))
2028                (let* ((preg (1- i)))
2029                  (declare (type (integer 0 15) preg))
2030                  (when (and (logbitp preg avail)
2031                             (not (find-conflicting-intervals interval preg)))
2032                    (setf (lreg-value lreg) preg
2033                          (interval-preg interval) preg)
2034                    (use-preg-in-interval preg interval)
2035                    (return-from resolve preg)))))))))))
2036
2037(defun resolvable-interval-conflict-p (interval reg src)
2038  (let* ((lreg (interval-lreg interval))
2039         (tdef (interval-trivial-def interval))
2040         (srci (lreg-interval src)))
2041    (declare (ignorable srci))
2042    (if (fixed-lreg-p lreg)
2043      (and tdef (eq reg (trivial-copy-source-operand tdef)))
2044      (let* ((win t))
2045        (unless (or (fixed-lreg-p src) (interval-trivial-def srci))
2046          ;;(pushnew interval (interval-conflicts-with srci))
2047          ;(setq win nil)
2048          ;;(break)
2049          )
2050          win)
2051      )))
2052
2053(defparameter *break-seqs* () ) ; for debugging
2054                                           
2055(defun nullify-trivial-copy (vinsn resolve)
2056  (let* ((win nil)
2057         (rebuild nil))
2058    (when (vinsn-attribute-p vinsn :trivial-copy)
2059      (let* ((vp (vinsn-variable-parts vinsn))
2060             (dest (svref vp 0))
2061             (src (svref vp 1)))
2062        (when (and (typep src 'lreg)
2063                   (typep dest 'lreg))
2064          ;; if both src and dest are lregs, dest
2065          ;; is not fixed, and doing so would not
2066          ;; introduce any conflicts throughout
2067          ;; the lifetime of dest, make the copy
2068          ;; a nop and change uses of dest to use
2069          ;; src directly
2070          ;; we are considering changing uses
2071          ;; of "dest" to use the same preg
2072          ;; as "src" does.  some other interval(s)
2073          ;; which did not conflict with "dest"
2074          ;; during register allocation may do
2075          ;; so now (if we back out of the copy)
2076          ;; if we find any such conflicting
2077          ;; intervals (which try to use the preg
2078          ;; from the src interval. change the
2079          ;; conflicting interval to use another
2080          ;; preg if we can.
2081     
2082       
2083       
2084       
2085          (let* ((src-interval (lreg-interval src))
2086                 (dest-interval (lreg-interval dest))
2087                 (src-preg (interval-preg src-interval))
2088                 (dest-preg (interval-preg dest-interval))
2089                 )
2090            (declare (type (unsigned-byte 4) src-preg dest-preg))
2091            ;;copying the register may be necessary to avoid cases
2092            ;; where we would otherwise destructively modify it and
2093            ;; reference the modified register after doing so.  E.g.
2094            ;; (prog1 (1+ x) ,,,) should not change X.
2095            ;; Will need to re-think this to handle more general control
2096            ;; flow (loops).
2097         
2098            (when (dolist (def (cdr (lreg-defs dest)) t)
2099                    (unless (vinsn-attribute-p def :trivial-copy)
2100                      (let* ((dseq (vinsn-sequence def)))
2101                        (declare (fixnum dseq))
2102                        (unless (dolist (ref (lreg-refs dest) t)
2103                                  (when (and (>= (the fixnum (vinsn-sequence ref)) dseq)
2104                                             (not (vinsn-attribute-p ref :trivial-copy)))
2105                                    ;;(ls-break "???")
2106                                                                                 
2107                                    (return nil)))
2108                          (return nil)))))
2109             
2110                                                       
2111
2112              (when (memq (vinsn-sequence vinsn) *break-seqs*) (break))
2113              (when (and resolve
2114                         (interval-conflicts dest-interval)
2115                         (getf (vinsn-annotation vinsn) :resolvable))
2116
2117           
2118                (dolist (conflict (interval-conflicts dest-interval) )
2119                  ;;(break)
2120                  ;;(resolve-interval-conflict conflict dest)
2121                  (setf (interval-conflicts-with conflict) nil)))
2122              (when (eql src-preg dest-preg)
2123                (setf (getf (vinsn-annotation vinsn) :resolvable) t))
2124              (unless (or (eql src-preg dest-preg)
2125                          (fixed-lreg-p dest)
2126                          )
2127
2128                (when (not resolve)
2129                  (dolist (i (find-conflicting-intervals dest-interval src-preg))
2130                 
2131                    ;; the conflicting interval was defined by a trivial-copy, but
2132                    ;; we might nullify that definition.
2133                    (unless (or (eq i src-interval) #|(interval-trivial-def i)|#)
2134                      (push dest-interval (interval-conflicts-with i))
2135                      (push i (interval-conflicts  dest-interval))))
2136
2137                  (when (dolist (i (interval-conflicts  dest-interval) t)
2138                          (unless (resolvable-interval-conflict-p  i dest src)
2139                       
2140                            (return nil)))
2141               
2142                    (setf (getf (vinsn-annotation vinsn) :resolvable) t))))
2143
2144
2145              (when (or (getf (vinsn-annotation vinsn) :resolvable) (eql src-preg dest-preg))
2146
2147                (if resolve
2148                  (unless (fixed-lreg-p dest)
2149                    (setf (lreg-value dest) src-preg
2150                          ))
2151                  (progn
2152                    (unless (eql src-preg dest-preg)
2153                      (unuse-preg-in-interval dest-preg dest-interval))   
2154                    (setf (interval-preg dest-interval)src-preg
2155                          ;;(interval-lreg dest-interval) nil
2156                          ;;(lreg-interval dest) src-interval
2157                          )
2158               
2159
2160                    ))
2161           
2162                   
2163
2164           
2165             
2166                (setq win t)
2167                )
2168              (when (and resolve (not (logbitp (interval-preg dest-interval)
2169                                               (interval-avail dest-interval))))
2170                (unless (getf (vinsn-annotation vinsn) :resolvable)
2171                  (if (fixed-lreg-p dest)
2172                    (linear-scan-bailout 'losing))
2173                  (dolist (other (interval-active-before dest-interval)) (pushnew other (interval-conflicts-with dest-interval)))
2174                  (resolve-interval-conflict dest-interval nil)
2175                  (when *linear-scan-verbose*
2176                    (break "~&funky at ~s" vinsn)))))
2177         
2178            )
2179
2180          )))
2181    (values  rebuild win)))
2182 
2183
2184
2185(defparameter *remove-trivial-copies* t)
2186
2187;; see postprocess-interval; this assumes that all trivial-copy operands
2188;; are lregs.
2189(defun remove-trivial-copies (seg)
2190  (declare (ignorable seg))
2191  (when  *remove-trivial-copies*
2192    (let* ((intervals (vinsn-list-intervals seg)))
2193      (declare (type (vector t) intervals))
2194      (dovector (i intervals)
2195        (when (interval-lreg i)
2196          (unless (interval-preg i)
2197            (setf (interval-preg i) (lreg-value (interval-lreg i))))
2198          (setf (interval-alt-preg i) (interval-preg i))
2199          (when *linear-scan-verbose*
2200            (format t "~&i=~s" i))
2201          (unless (and (logbitp (interval-preg i) (interval-avail i))
2202                       (dolist (after (interval-active-after i) t)
2203                         (when (logbitp (interval-preg i) (interval-avail after))
2204                           
2205                           (return nil)))))))
2206     
2207     
2208                                                                 
2209      (when *linear-scan-verbose*
2210        (format t " ~&before:~&")
2211        (show-vinsn-list seg))
2212      (rebuild-avail-before seg)
2213      '(unless (check-intervals seg)
2214        (linear-scan-bailout 'early-inconsistency))
2215      (dolist (block (vinsn-list-flow-graph seg))
2216        (do-tail-dll-nodes (v block)
2217          (when (vinsn-attribute-p v :trivial-copy)
2218            (nullify-trivial-copy v nil))))
2219      (rebuild-avail-before seg)
2220      (resolve-non-trivial-interval-conflicts seg)
2221      (dolist (block (vinsn-list-flow-graph seg))
2222        (do-tail-dll-nodes (v block)
2223          (when (vinsn-attribute-p v :trivial-copy)
2224
2225            (nullify-trivial-copy v t))))
2226      (when *linear-scan-verbose*
2227        (format t "~&after:~&")
2228        (show-vinsn-list seg))
2229      (when *linear-scan-verbose*
2230        (format t "~&removed trivial-copy vinsns from ~s" *current-function-name*))
2231      )))
2232
2233
2234
2235
2236(defun optimize-vinsns (header)
2237
2238 
2239  ;; Delete unreferenced labels that the compiler might have emitted.
2240  ;; Subsequent operations may cause other labels to become
2241  ;; unreferenced.
2242  (let* ((regs (vinsn-list-lregs header)))
2243
2244    (merge-adjacent-labels header)
2245    ;; Look for pairs of adjacent, referenced labels.
2246    ;; Merge them together (so that one of them becomes unreferenced.)
2247    ;; Repeat the process until no pairs are found.
2248
2249    (maximize-jumps header)
2250    (eliminate-dead-code header) 
2251    (cond (*backend-use-linear-scan*
2252           (let* ((size (dll-header-length header)))
2253             (when (> size 10000)
2254               (linear-scan-bailout 'function-size)) 
2255             )
2256           (normalize-vinsns header)
2257           (let* ((fg (create-flow-graph header))
2258                  (seq 0))
2259             (declare (fixnum seq))
2260             (dolist (node fg (setf (vinsn-list-max-seq header) seq))
2261               (do-dll-nodes (v node)
2262                 (when (typep v 'vinsn)
2263                   (setf (vinsn-fgn v) node
2264                         (vinsn-sequence v) (incf seq 5)))))
2265             (compute-live-sets fg header)
2266             (setf (vinsn-list-available-physical-registers header)
2267                   (vector *backend-node-temps*
2268                           *backend-imm-temps*
2269                           *backend-fp-temps*
2270                           *backend-crf-temps*))
2271             (build-interval-list header)
2272             #(and later +x86-target)
2273             (when (eq *linear-scan-verbose* :very)
2274               (ls-format "~&**********************************************~s" (afunc-name *x862-cur-afunc*))
2275               (dolist (n fg )
2276                 (terpri)
2277                 (show-fgn n (vinsn-list-lregs header))))
2278             (unless (linear-scan header )
2279               (linear-scan-bailout 'register-allocator-failed))
2280
2281             (remove-trivial-copies header)
2282             (when *report-linear-scan-success*
2283               (format *debug-io*  "~&;; Won on ~a" *current-function-name*))
2284             (incf *linear-scan-won*)
2285             (setq *using-linear-scan-won* t)
2286             (resolve-split-intervals header)
2287             (process-spills-and-reloads fg)
2288             (when (eq *linear-scan-verbose* :very)
2289               (dolist (n fg )
2290                 (terpri)
2291                 (show-fgn n regs)))
2292
2293             (linearize-flow-graph fg header)
2294             (try-to-omit-frame-pointer header)
2295             t))
2296          (t t))))
2297
2298(defun find-vinsn (seg seq)
2299  (flet ((find-vinsn-in-node (node seq)
2300           (do-tail-dll-nodes (v node)
2301             (when (typep v 'vinsn)
2302               (let*  ((vseq (vinsn-sequence v)))
2303                 (if (eq vseq seq)
2304                   (return v)))))))
2305    (dolist (node (vinsn-list-flow-graph seg))
2306      (let* ((lastv (dll-header-last node)))
2307        (when (>= (vinsn-sequence lastv) seq)
2308          (return (find-vinsn-in-node node seq)))))))
2309
2310(defun show-vinsns (vinsns indent)
2311 (do-dll-nodes (n vinsns)
2312  (ls-format "~&~v@t~s" indent n)))
2313
2314(defun show-vinsn-range (first last indent)
2315 (do* ((vinsn first (dll-node-succ vinsn)))
2316    ()
2317  (ls-format "~&~v@t~s" indent vinsn)
2318  (when (eq vinsn last) (return))))
2319
2320(defun show-vinsn-list (seg)
2321  (when *linear-scan-verbose*
2322    (dolist (block (vinsn-list-flow-graph seg))
2323      (show-fgn block nil nil))))
2324
2325(defun show-fgn (node regs &optional (show-live-sets t))
2326  (declare (ignorable regs))
2327  (format t "~&~s (~d) {~a}" (type-of node) (fgn-id node) (mapcar #'fgn-id (fgn-inedges node)))
2328  (show-vinsns node 2)
2329  (when show-live-sets
2330    (show-live-set "live-kill" (fgn-live-kill node) regs)
2331    (show-live-set "live-gen " (fgn-live-gen node) regs)
2332    (show-live-set "live-in " (fgn-live-in node) regs)
2333    (show-live-set "live-out " (fgn-live-out node) regs))
2334 
2335  (terpri)
2336  (terpri))
2337
2338(defun show-live-set (herald bits regs)
2339 (format t "~&~a" herald)
2340 (collect ((reg))
2341  (dotimes (i (length regs) (format t " ~s" (reg)))
2342   (let* ((lreg (aref regs i)))
2343    (when (eql 1 (sbit bits i))
2344     (reg lreg))))))
2345                   
2346 
2347
2348(defun dfs-walk (fgns &key
2349                   process-before process-after
2350                   process-succ-before process-succ-after)
2351  (labels ((dfs (node)
2352           (when process-before
2353            (funcall process-before node))
2354           (setf (fgn-visited node) t)
2355           (when (typep node 'jumpnode)
2356            (let* ((outedge (jumpnode-outedge node)))
2357                 (unless (fgn-visited outedge)
2358                  (when process-succ-before
2359                   (funcall process-succ-before outedge))
2360                  (dfs outedge)
2361                  (when process-succ-after
2362                   (funcall process-succ-after outedge))))
2363            (when (typep node 'condnode)
2364                 (let* ((branchedge (branch-target-node
2365                                   (condnode-condbranch node))))
2366                  (unless (fgn-visited branchedge)
2367                   (when process-succ-before
2368                    (funcall process-succ-before branchedge))
2369                   (dfs branchedge)
2370                   (when process-succ-after
2371                    (funcall process-succ-after branchedge))))))
2372           (when process-after
2373            (funcall process-after node)))
2374          )
2375  (dolist (n fgns)
2376   (setf (fgn-visited n) nil))
2377  (dfs (car fgns))))
2378
2379(defun dfs-postorder (fgns)
2380 (let* ((n (length fgns))
2381         (v (make-array n))
2382         (p -1)
2383         (process-after #'(lambda (node)
2384                          (setf (svref v (incf p)) node))))
2385  (declare (fixnum p) (dynamic-extent process-after))
2386  (dfs-walk fgns :process-after process-after)
2387  v))
2388
2389   
2390(defun last-vinsn-unless-label (seg)
2391  ;; Look at the last element(s) of seg. If a vinsn-note,
2392  ;; keep looking. If a vinsn, return it; if a vinsn-label,
2393  ;; return nil
2394  (do* ((element (dll-header-last seg) (dll-node-pred element)))
2395       ((eq element seg))
2396    (etypecase element
2397      (vinsn (return element))
2398      (vinsn-label (if (typep (vinsn-label-id element) 'fixnum)
2399                     (return nil))))))
2400   
2401
2402
2403
2404;;; This generally only gives a meaningful result if pass 2 of the
2405;;; compiler has been compiled in the current session.
2406;;; TODO (maybe): keep track of the "expected missing vinsns" for
2407;;; each backend, call this function after compiling pass 2. That's
2408;;; a little weird, since it'd require modifying backend X whenever
2409;;; backend Y changes, but it's probably better than blowing up when
2410;;; compiling user code.
2411(defun missing-vinsns (&optional (backend *target-backend*))
2412 (let* ((missing ()))
2413  (maphash #'(lambda (name info)
2414         (unless (cdr info)
2415          (push name missing)))
2416       (backend-p2-vinsn-templates backend))
2417  missing))
2418                   
2419(provide "VINSN")
Note: See TracBrowser for help on using the repository browser.