source: branches/working-0711/ccl/compiler/vinsn.lisp @ 7941

Last change on this file since 7941 was 7941, checked in by gb, 13 years ago

Try to avoid jumping/branching to jumps. (NB: this requires some
changes to vinsn attributes, so that :JUMP is only used for absolute
pc-relative unconditional branches; that may not yet be true on PPC.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 28.5 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17
18(cl:eval-when (:compile-toplevel :load-toplevel :execute)
19  (require "DLL-NODE")
20  (require "BACKEND"))
21
22
23(cl:in-package "CCL")
24
25;;; Specifying the same name for a result and an argument basically
26;;; says that it's ok for the vinsn to clobber that argument.  (In all
27;;; other cases, arguments are assumed to be "read-only", and damned
28;;; well better be.)  Any results that are also arguments must follow
29;;; all results that aren't in the "results" list; any arguments that
30;;; are also results must precede all arguments that aren't in the
31;;; "arguments" list, and all hybrids must appear in the same order in
32;;; both lists. This is what "nhybrids" is about (and why it defaults
33;;; to 0 ...)  Sometimes (often) these hybrid "results" aren't very
34;;; interesting as results;;; it might be clearer to consider
35;;; "mutable" arguments as quasi-temporaries.
36(defstruct vinsn-template
37  name                                  ; a symbol in the target package
38  result-vreg-specs                     ; one or more vreg specs for values defined by the vinsn
39  argument-vreg-specs                   ; may ultimately overlap some result vreg(s)
40  ; one or more vreg specs for temporaries used in vinsn.
41  ; all such temporaries are assumed to have lifetimes which span all
42  ; machine instructions in the vinsn (e.g., they can't conflict with any
43  ; registers used for args/results and may have further constraints.
44  temp-vreg-specs                 
45  local-labels
46  body                                  ; list of target instructions, local labels
47  (nhybrids 0)
48  (nvp 0)
49  results&args                          ;
50  (attributes 0)                        ; attribute bitmask
51  opcode-alist                          ; ((number1 . name1) (number2 . name2) ...)
52)
53
54(defmethod make-load-form ((v vinsn-template) &optional env)
55  (make-load-form-saving-slots v :environment env))
56
57
58(defun get-vinsn-template-cell (name templates)
59  (let* ((n (intern (string name) *ccl-package*)))
60    (or (gethash n templates)
61        (setf (gethash n templates) (cons n nil)))))
62
63(defun need-vinsn-template (name templates)
64  (or (cdr (if (consp name) name (get-vinsn-template-cell name templates)))
65      (error "Unknown vinsn: ~s" name)))
66
67(defun set-vinsn-template (name template templates)
68  (setf (cdr (get-vinsn-template-cell name templates)) template))
69
70(defstruct (vinsn (:include dll-node)
71                  (:print-function print-vinsn)
72                  (:constructor %make-vinsn (template)))
73  template                              ; The vinsn-template of which this is an instance
74  variable-parts                        ; vector of result-vregs, arguments, temps, local-labels
75  annotation
76  (gprs-set 0)
77  (fprs-set 0)
78)
79
80(def-standard-initial-binding *vinsn-freelist* (make-dll-node-freelist))
81
82(defun make-vinsn (template)
83  (let* ((vinsn (alloc-dll-node *vinsn-freelist*)))
84    (loop
85      ; Sometimes, the compiler seems to return its node list
86      ; to the freelist without first removing the vinsn-labels in it.
87      (if (or (null vinsn) (typep vinsn 'vinsn)) (return))
88      (setq vinsn (alloc-dll-node *vinsn-freelist*)))
89    (if vinsn
90      (progn
91        (setf (vinsn-template vinsn) template
92              (vinsn-variable-parts vinsn) nil
93              (vinsn-annotation vinsn) nil
94              (vinsn-gprs-set vinsn) 0
95              (vinsn-fprs-set vinsn) 0)
96        vinsn)
97      (%make-vinsn template))))
98
99(eval-when (:load-toplevel :execute)
100(defstruct (vinsn-label (:include dll-node)
101                        (:print-function print-vinsn-label)
102                        (:predicate %vinsn-label-p)
103                        (:constructor %make-vinsn-label (id)))
104  id
105  refs                                  ; vinsns in which this label appears as an operand
106  info                                  ; code-generation stuff
107)
108)
109
110(def-standard-initial-binding *vinsn-label-freelist* (make-dll-node-freelist))
111
112(defun make-vinsn-label (id)
113  (let* ((lab (alloc-dll-node *vinsn-label-freelist*)))
114    (if lab
115      (progn
116        (setf (vinsn-label-id lab) id
117              (vinsn-label-refs lab) nil
118              (vinsn-label-info lab) nil)
119        lab)
120      (%make-vinsn-label id))))
121
122; "Real" labels have fixnum IDs.
123(defun vinsn-label-p (l)
124  (if (%vinsn-label-p l) 
125    (typep (vinsn-label-id l) 'fixnum)))
126
127
128(defun print-vinsn-label (l s d)
129  (declare (ignore d))
130  (print-unreadable-object (l s :type t)
131    (format s "~d" (vinsn-label-id l))))
132
133;;; Notes are attached to (some) vinsns.  They're used to attach
134;;; semantic information to an execution point.  The vinsn
135;;; points to the note via its LABEL-ID; the note has a backpointer to
136;;; the vinsn.
137
138(defstruct (vinsn-note
139            (:constructor %make-vinsn-note)
140            (:print-function print-vinsn-note))
141  (label (make-vinsn-label nil))
142  (peer nil :type (or null vinsn-note))
143  (class nil)
144  (info nil :type (or null simple-vector)))
145
146
147(defun print-vinsn-note (n s d)
148  (declare (ignore d))
149  (print-unreadable-object (n s :type t)
150    (format s "~d" (vinsn-note-class n))
151    (let* ((info (vinsn-note-info n)))
152      (when info (format s " / ~S" info)))))
153 
154(defun make-vinsn-note (class info)
155  (let* ((n (%make-vinsn-note :class class :info (if info (apply #'vector info))))
156         (lab (vinsn-note-label n)))
157    (setf (vinsn-label-id lab) n)
158    n))
159
160(defun close-vinsn-note (n)
161  (let* ((end (%make-vinsn-note :peer n)))
162    (setf (vinsn-label-id (vinsn-note-label end)) end
163          (vinsn-note-peer end) n
164          (vinsn-note-peer n) end)
165    end))
166       
167
168(defun vinsn-vreg-description (value spec)
169  (case (cadr spec)
170    ((:u32 :s32 :u16 :s16 :u8 :s8 :lisp :address :imm)
171     (let* ((mode (if (typep value 'fixnum)
172                    (get-regspec-mode value))))
173       (if (and mode (not (eql 0 mode)))
174         (list (hard-regspec-value value)
175               (car (rassoc mode *mode-name-value-alist* :test #'eq)))
176         value)))
177    (t value)))
178
179(defun collect-vinsn-variable-parts (v start n &optional specs)
180  (declare (fixnum start n))
181  (let* ((varparts (vinsn-variable-parts v)))
182    (when varparts
183      (let* ((head (cons nil nil))
184             (tail head))
185        (declare (dynamic-extent head) (cons head tail))
186        (do* ((j start (1+ j))
187              (i 0 (1+ i)))
188             ((= i n) (cdr head))
189          (declare (fixnum i j))
190          (setq tail (cdr (rplacd tail (cons (vinsn-vreg-description (svref varparts j) (pop specs)) nil)))))))))
191
192     
193(defun collect-vinsn-results (v)
194  (let* ((template (vinsn-template v))
195         (result-specs (vinsn-template-result-vreg-specs template)))
196    (collect-vinsn-variable-parts v 0 (length result-specs) result-specs)))
197
198(defun collect-vinsn-arguments (v)
199  (let* ((template (vinsn-template v))
200         (arg-specs (vinsn-template-argument-vreg-specs template)))
201    (collect-vinsn-variable-parts v
202                                  (- (length (vinsn-template-result-vreg-specs template)) 
203                                     (vinsn-template-nhybrids template))
204                                  (length arg-specs)
205                                  arg-specs)))
206
207(defun collect-vinsn-temps (v)
208  (let* ((template (vinsn-template v)))
209    (collect-vinsn-variable-parts v 
210                                  (+
211                                   (length (vinsn-template-result-vreg-specs template)) 
212                                   (length (vinsn-template-argument-vreg-specs template)))
213                                  (length (vinsn-template-temp-vreg-specs template)))))
214
215(defun template-infix-p (template)
216  (declare (ignore template))
217  nil)
218
219(defun print-vinsn (v stream d)
220  (declare (ignore d))
221  (let* ((template (vinsn-template v))
222         (results (collect-vinsn-results v))
223         (args (collect-vinsn-arguments v))
224         (opsym (if (cdr results) :== :=))
225         (infix (and (= (length args) 2) (template-infix-p template)))
226         (opname (vinsn-template-name template)))
227    (print-unreadable-object (v stream)
228      (if results (format stream "~A ~S " (if (cdr results) results (car results)) opsym))
229      (if infix
230        (format stream "~A ~A ~A" (car args) opname (cadr args))
231        (format stream "~A~{ ~A~}" opname args))
232      (let* ((annotation (vinsn-annotation v)))
233        (when annotation
234          (format stream " ||~a|| " annotation))))))
235 
236(defparameter *known-vinsn-attributes*
237  '(
238    :jump                               ; an unconditional branch
239    :branch                             ; a conditional branch
240    :call                               ; a jump that returns
241    :funcall                            ; A full function call, assumed to bash all volatile registers
242    :subprim-call                       ; A subprimitive call; bashes some volatile registers
243    :jumpLR                             ; Jumps to the LR, possibly stopping off at a function along the way.
244    :lrsave                             ; saves LR in LOC-PC
245    :lrrestore                          ; restores LR from LOC-PC
246    :lispcontext                        ; references lisp frame LOC-PC, FN, and entry VSP
247    :node                               ; saves/restores a node value in stack-like memory
248    :word                               ; saves/restores an unboxed word in stack-like memory
249    :doubleword                         ; saves/restores an unboxed doubleword (fp-reg) in stack-like memory
250    :vsp                                ; uses the vsp to save/restore
251    :tsp                                ; uses the tsp to save/restore
252    :csp                                ; uses sp to save/restore
253    :push                               ; saves something
254    :pop                                ; restores something
255    :multiple                           ; saves/restores multiple nodes/words/doublewords
256    :ref                                ; references memory
257    :set                                ; sets memory
258    :outgoing-argument                  ; e.g., pushed as an argument, not to avoid clobbering
259    :xref                               ; makes some label externally visible
260    :jump-unknown                       ; Jumps, but we don't know where ...
261    :constant-ref
262    :sets-cc                            ; vinsn sets condition codes based on result
263    ))
264
265(defparameter *nvp-max* 10 "size of *vinsn-varparts* freelist elements")
266(def-standard-initial-binding *vinsn-varparts* (%cons-pool))
267
268(defun alloc-varparts-vector ()
269  (without-interrupts
270   (let* ((v (pool.data *vinsn-varparts*)))
271     (if v
272       (progn
273         (setf (pool.data *vinsn-varparts*)
274               (svref v 0))
275          (%init-misc 0 v)
276         v)
277       (make-array (the fixnum *nvp-max*) :initial-element 0)))))
278
279(defun free-varparts-vector (v)
280  (without-interrupts
281   (setf (svref v 0) (pool.data *vinsn-varparts*)
282         (pool.data *vinsn-varparts*) v)
283   nil))
284
285(defun elide-vinsn (vinsn)
286  (let* ((nvp (vinsn-template-nvp (vinsn-template vinsn)))
287         (vp (vinsn-variable-parts vinsn)))
288    (dotimes (i nvp)
289      (let* ((v (svref vp i)))
290        (when (typep v 'lreg)
291          (setf (lreg-defs v) (delete vinsn (lreg-defs v)))
292          (setf (lreg-refs v) (delete vinsn (lreg-refs v))))))
293    (free-varparts-vector vp)
294    (remove-dll-node vinsn)))
295   
296(defun encode-vinsn-attributes (attribute-list)
297  (flet ((attribute-weight (k)
298           (let* ((pos (position k *known-vinsn-attributes*)))
299             (if pos (ash 1 pos) (error "Unknown vinsn attribute: ~s" k)))))
300    (let* ((attr 0))
301      (declare (fixnum attr))
302      (dolist (a attribute-list attr)
303        (setq attr (logior attr (the fixnum (attribute-weight a))))))))
304
305
306(defun %define-vinsn (backend vinsn-name results args temps body)
307  (funcall (backend-define-vinsn backend)
308           backend
309           vinsn-name
310           results
311           args
312           temps
313           body))
314
315
316;; Fix the opnum's in the vinsn-template-body to agree with the
317;; backend's opcode hash table.
318(defun fixup-vinsn-template (orig-template opcode-hash)
319  (let ((template (cdr orig-template)))
320    (when template
321      (unless (vinsn-template-p template)
322        (setq template (require-type template 'vinsn-template)))
323      (let ((new-opcode-alist nil)
324            (changes nil)
325            (opcode-alist (vinsn-template-opcode-alist template)))
326        ;; this is patterned after ppc2-expand-vinsn
327        (labels ((walk-form (f)
328                   (unless (atom f)
329                     (if (fixnump (car f))
330                       (got-one f)
331                       (dolist (subform (cdr f))
332                         (walk-form subform)))))
333                 (got-one (f)
334                   (let* ((old-opcode (car f))
335                          (name (cdr (assq old-opcode opcode-alist)))
336                          (new-opcode (and name (gethash name opcode-hash))))
337                     (unless new-opcode
338                       (cerror "Continue" "Can't find new opcode number ~
339                                   for ~s in ~s" (car f) template))
340                     (setf (assq new-opcode new-opcode-alist) name)
341                     (unless (eq new-opcode old-opcode)
342                       (push (cons f new-opcode) changes)))))
343          (mapc #'walk-form (vinsn-template-body template))
344          (without-interrupts
345           (dolist (change changes)
346             (setf (caar change) (cdr change)))
347           (setf (vinsn-template-opcode-alist template)
348                 new-opcode-alist))))
349      orig-template)))
350
351(defun fixup-vinsn-templates (templates opcode-hash-table)
352  (maphash #'(lambda (name template)
353               (declare (ignore name))
354               (fixup-vinsn-template template opcode-hash-table))
355           templates))
356                                       
357;;; Could probably split this up and do some arg checking at macroexpand time.
358(defun match-template-vregs (template vinsn supplied-vregs)
359  (declare (list supplied-vregs))
360  (let* ((nsupp (length supplied-vregs))
361         (results&args (vinsn-template-results&args template))
362         (nra (length results&args))
363         (temp-specs (vinsn-template-temp-vreg-specs template))
364         (ntemps (length temp-specs))
365         (nvp (vinsn-template-nvp template))
366         (vp (alloc-varparts-vector))
367         (*available-backend-node-temps* *available-backend-node-temps*)
368         (*available-backend-fp-temps* *available-backend-fp-temps*)
369         (*available-backend-imm-temps* *available-backend-imm-temps*)
370         (*available-backend-crf-temps* *available-backend-crf-temps*))
371    (declare (fixnum nvp ntemps nsupp)
372             (list result-specs temp-specs arg-specs))
373    (unless (= nsupp nra)
374      (error "Vinsn ~A expects ~D result/argument specs, received ~D ."
375             (vinsn-template-name template) nra nsupp))
376    (do* ((i 0 (1+ i))
377          (supp supplied-vregs (cdr supp))
378          (spec results&args (cdr spec)))
379         ((null supp))
380      (declare (fixnum i) (list spec supp))
381      (setf (svref vp i) (match-vreg (car supp) (cadar spec) vinsn vp i)))
382    ;; Allocate some temporaries.
383    (do* ((i (- nvp ntemps) (1+ i))
384          (temps temp-specs (cdr temps)))
385         ((null temps) vp)
386      (declare (fixnum i))
387      (let* ((spec (cadar temps)))
388        (if (and (consp spec) (eq (car spec) :label))
389          (let* ((label (aref *backend-labels* (cadr spec))))
390            (push vinsn (vinsn-label-refs label))
391            (setf (svref vp i) label))
392          (let* ((lreg (allocate-temporary-vreg (car temps)))
393                 (class (hard-regspec-class lreg))
394                 (value (hard-regspec-value lreg)))
395            (when value
396              (case class
397                (#.hard-reg-class-gpr (note-vinsn-sets-gpr vinsn value))
398                (#.hard-reg-class-fpr (note-vinsn-sets-fpr vinsn value))))
399            (setf (svref vp i) lreg)
400            (pushnew vinsn (lreg-defs lreg))
401            (pushnew vinsn (lreg-refs lreg))))))))
402
403;;; "spec" is (<name> <class>).
404;;;  <class> is keyword or (<keyword> <val>)
405(defun allocate-temporary-vreg (spec)
406  (setq spec (cadr spec))
407  (let* ((class (if (atom spec) spec (car spec)))
408         (value (if (atom spec) nil (cadr spec))))
409    (if value
410      (ecase class
411        (:crf (make-wired-lreg (use-crf-temp value) :class hard-reg-class-crf))
412        ((:u8 :s8 :u16 :s16 :u32 :s32 :u64 :s64) 
413         (make-wired-lreg (use-imm-temp value)
414                          :class hard-reg-class-gpr
415                          :mode (gpr-mode-name-value class)))
416        (:lisp (make-wired-lreg 
417                (use-node-temp value) 
418                :class hard-reg-class-gpr
419                :mode hard-reg-class-gpr-mode-node)))
420      (ecase class
421        ((:imm :wordptr) 
422         (make-unwired-lreg
423          (if (= *available-backend-imm-temps* 0) (select-node-temp) (select-imm-temp))
424              :class hard-reg-class-gpr
425              :mode hard-reg-class-gpr-mode-node)) 
426        ((:u8 :s8 :u16 :s16 :u32 :s32 :u64 :s64) 
427         (make-unwired-lreg (select-imm-temp)
428                            :class hard-reg-class-gpr
429                            :mode (gpr-mode-name-value class)))
430        (:lisp 
431         (make-unwired-lreg 
432          (select-node-temp) 
433          :class hard-reg-class-gpr
434          :mode hard-reg-class-gpr-mode-node))
435        (:crf 
436         (make-unwired-lreg (select-crf-temp) :class hard-reg-class-crf))))))
437
438
439
440(defun select-vinsn (template-or-name template-hash vregs)
441  (let* ((template (need-vinsn-template template-or-name template-hash))
442         (vinsn (make-vinsn template)))
443    (setf (vinsn-variable-parts vinsn) (match-template-vregs template vinsn vregs))
444    vinsn))
445
446(defun %emit-vinsn (vlist name vinsn-table &rest vregs)
447  (append-dll-node (select-vinsn name vinsn-table vregs) vlist))
448
449(defun varpart-matches-reg (varpart-value class regval spec)
450  (setq spec (if (atom spec) spec (car spec)))
451  (and
452   (or
453    (and (eq class hard-reg-class-fpr)
454         (memq spec '(:single-float :double-float)))
455    (and (eq class hard-reg-class-gpr)
456         (memq spec '(:u32 :s32 :u16 :s16 :u8 :s8 :lisp :address :imm))))
457   (eq (hard-regspec-value varpart-value) regval)))
458
459(defun vinsn-sets-reg-p (element reg)
460  (if (typep element 'vinsn)
461    (if (vinsn-attribute-p element :call)
462      t
463      (let* ((class (hard-regspec-class reg))
464             (value (hard-regspec-value reg)))
465        (if (eq class hard-reg-class-gpr)
466          (logbitp value (vinsn-gprs-set element))
467          (if (eq class hard-reg-class-fpr)
468            (logbitp value (vinsn-fprs-set element))))))))
469
470;;; Return bitmasks of all GPRs and all FPRs set in the vinsns between
471;;; START and END, exclusive.  Any :call vinsn implicitly clobbers
472;;; all registers.
473(defun regs-set-in-vinsn-sequence (start end)
474  (let* ((gprs-set 0)
475         (fprs-set 0))
476    (do* ((element (vinsn-succ start) (vinsn-succ element)))
477         ((eq element end) (values gprs-set fprs-set))n
478      (if (typep element 'vinsn)
479        (if (vinsn-attribute-p element :call)
480          (return (values #xffffffff #xffffffff))
481          (setq gprs-set (logior (vinsn-gprs-set element))
482                fprs-set (logior (vinsn-fprs-set element))))))))
483     
484;;; Return T if any vinsn between START and END (exclusive) sets REG.
485(defun vinsn-sequence-sets-reg-p (start end reg)
486  (do* ((element (vinsn-succ start) (vinsn-succ element)))
487       ((eq element end))
488    (if (vinsn-sets-reg-p element reg)
489      (return t))))
490       
491
492;;; Flow-graph nodes (FGNs)
493
494(defstruct (fgn (:include dll-header))
495  (id 0 :type unsigned-byte)
496  (inedges ())                          ; list of nodes which reference this node
497  (visited nil)                         ; Boolean
498)
499
500
501
502;;; FGNs which don't terminate with an "external jump"
503;;; (jump-return-pc/jump-subprim, etc) jump to their successor, either
504;;; explicitly or by falling through.  We can introduce or remove
505;;; jumps when linearizing the program.
506(defstruct (jumpnode (:include fgn)
507                     (:constructor %make-jumpnode (id)))
508  (outedge)                             ; the FGN we jump/fall in to.
509)
510
511(defun make-jumpnode (id)
512  (init-dll-header (%make-jumpnode id)))
513   
514;;; A node that ends in a conditional branch, followed by an implicit
515;;; or explicit jump.  Keep track of the conditional branch and the
516;;; node it targets.
517(defstruct (condnode (:include jumpnode)
518                     (:constructor %make-condnode (id)))
519  (condbranch)                          ; the :branch vinsn
520  (branchedge)                          ; the FGN it targets
521)
522
523(defun make-condnode (id)
524  (init-dll-header (%make-condnode id)))
525         
526;;; A node that terminates with a return i.e., a jump-return-pc or
527;;; jump-subprim.
528(defstruct (returnnode (:include fgn)
529                       (:constructor %make-returnnode (id)))
530)
531
532(defun make-returnnode (id)
533  (init-dll-header (%make-returnnode id)))
534
535;;; Some specified attribute is true.
536(defun %vinsn-attribute-p (vinsn mask)
537  (declare (fixnum mask))
538  (if (vinsn-p vinsn)
539    (let* ((template (vinsn-template vinsn)))
540      (not (eql 0 (logand mask (the fixnum (vinsn-template-attributes template))))))))
541
542;;; All specified attributes are true.
543(defun %vinsn-attribute-= (vinsn mask)
544  (declare (fixnum mask))
545  (if (vinsn-p vinsn)
546    (let* ((template (vinsn-template vinsn)))
547      (= mask (the fixnum (logand mask (the fixnum (vinsn-template-attributes template))))))))
548 
549(defmacro vinsn-attribute-p (vinsn &rest attrs)
550  `(%vinsn-attribute-p ,vinsn ,(encode-vinsn-attributes attrs)))
551
552(defmacro vinsn-attribute-= (vinsn &rest attrs)
553  `(%vinsn-attribute-= ,vinsn ,(encode-vinsn-attributes attrs)))
554
555;;; Ensure that conditional branches that aren't followed by jumps are
556;;; followed by (jump lab-next) @lab-next.  Ensure that JUMPs and
557;;; JUMPLRs are followed by labels.  It's easiest to do this by
558;;; walking backwards.  When we're all done, labels will mark the
559;;; start of each block.
560
561(defun normalize-vinsns (header)
562  (do* ((prevtype :label currtype)
563        (current (dll-header-last header) (dll-node-pred current))
564        (currtype nil))
565       ((eq current header)
566        (unless (eq prevtype :label)
567          (insert-dll-node-after
568           (aref *backend-labels* (backend-get-next-label))
569           current)))
570    (setq currtype (cond ((vinsn-label-p current) :label)
571                         ((vinsn-attribute-p current :branch) :branch)
572                         ((vinsn-attribute-p current :jump) :jump)
573                         ((vinsn-attribute-p current :jumplr) :jumplr)))
574    (case currtype
575      ((:jump :jumplr)
576       (unless (eq prevtype :label)
577         (let* ((lab (aref *backend-labels* (backend-get-next-label))))
578           (insert-dll-node-after lab current))))
579      (:branch
580       (unless (eq prevtype :jump)
581         (let* ((lab
582                 (if (eq prevtype :label)
583                   (dll-node-succ current)
584                   (aref *backend-labels* (backend-get-next-label))))
585                (jump (select-vinsn "JUMP" *backend-vinsns* (list lab))))
586           (unless (eq prevtype :label)
587             (insert-dll-node-after lab current))
588           (insert-dll-node-after jump current))))
589      ((nil)
590       (if (eq prevtype :label)
591         (let* ((lab (dll-node-succ current)))
592           (when (vinsn-label-p lab)
593             (insert-dll-node-after
594              (select-vinsn "JUMP" *backend-vinsns* (list lab))
595              current))))))))
596
597
598;;; Unless the header is empty, remove the last vinsn and all preceding
599;;; vinsns up to and including the preceding label.  (Since the vinsns
600;;; have been normalized, there will always be a preceding label.)
601;;; Return the label and the last vinsn, or (values nil nil.)
602(defun remove-last-basic-block (vinsns)
603  (do* ((i 1 (1+ i))
604        (current (dll-header-last vinsns) (dll-node-pred current)))
605       ((eq current vinsns) (values nil nil))
606    (declare (fixnum i))
607    (if (vinsn-label-p current)
608      (return (remove-dll-node current i)))))
609
610;;; Create a flow graph from vinsns and return the entry node.
611(defun create-flow-graph (vinsns)
612  (let* ((nodes ()))
613    (declare (fixnum id))
614    (flet ((label->fgn (label) (dll-node-pred label)))
615      (loop
616          (multiple-value-bind (label last) (remove-last-basic-block vinsns)
617            (when (null label) (return))
618            (let* ((id (vinsn-label-id label))
619                   (node (if (vinsn-attribute-p last :jumpLR)
620                           (make-returnnode id)
621                           (if (vinsn-attribute-p (dll-node-pred last) :branch)
622                             (make-condnode id)
623                             (make-jumpnode id)))))
624              (insert-dll-node-after label node last)
625              (push node nodes))))
626      (dolist (node nodes nodes)
627        (if (typep node 'jumpnode)
628          (let* ((jump (dll-header-last node))
629                 (jmptarget (branch-target-node jump)))
630            (setf (jumpnode-outedge node) jmptarget)
631            (pushnew node (fgn-inedges jmptarget))
632            (if (typep node 'condnode)  ; a subtype of jumpnode
633              (let* ((branch (dll-node-pred jump))
634                     (branchtarget (branch-target-node branch)))
635                (setf (condnode-condbranch node) branch)
636                (pushnew node (fgn-inedges branchtarget))))))))))
637 
638                         
639(defun delete-unreferenced-labels (labels)
640  (delete #'(lambda (l)
641              (unless (vinsn-label-refs l)
642                (when (vinsn-label-succ l)
643                  (remove-dll-node l))
644                t)) labels :test #'funcall))
645
646(defun branch-target-node (v)
647  (dll-node-pred (svref (vinsn-variable-parts v) 0)))
648
649(defun replace-label-refs (vinsn old-label new-label)
650  (let ((vp (vinsn-variable-parts vinsn)))
651    (dotimes (i (length vp))
652      (when (eq (svref vp i) old-label)
653        (setf (svref vp i) new-label)))))
654 
655;;; Try to remove jumps/branches to jumps.
656(defun maximize-jumps (header)
657  (do* ((prev nil next)
658        (next (dll-header-first header) (dll-node-succ next)))
659       ((eq next header))
660    (when (and (vinsn-attribute-p next :jump)
661               (vinsn-label-p  prev))
662      (let* ((target (svref (vinsn-variable-parts next) 0)))
663        (unless (eq target prev)
664          (dolist (ref (vinsn-label-refs prev) (setf (vinsn-label-refs prev) nil))
665            (replace-label-refs ref prev target)
666            (push ref (vinsn-label-refs target))))))))
667
668(defun optimize-vinsns (header)
669  ;; Delete unreferenced labels that the compiler might have emitted.
670  ;; Subsequent operations may cause other labels to become
671  ;; unreferenced.
672  (let* ((labels (collect ((labs)) 
673                   (do-dll-nodes (v header)
674                     (when (vinsn-label-p v) (labs v)))
675                   (labs))))
676    ;; Look for pairs of adjacent, referenced labels.
677    ;; Merge them together (so that one of them becomes unreferenced.)
678    ;; Repeat the process until no pairs are found.
679    (do* ((repeat t))
680         ((not repeat))
681      (setq repeat nil 
682            labels (delete-unreferenced-labels labels))
683      (dolist (l labels)
684        (let* ((succ (vinsn-label-succ l)))
685          (when (vinsn-label-p succ)
686            (backend-merge-labels l succ)
687            (setq repeat t)
688            (return)))))
689    (maximize-jumps header)
690    (delete-unreferenced-labels labels)
691    (normalize-vinsns header)
692  ))
693
694(defun show-vinsns (vinsns indent)
695  (do-dll-nodes (n vinsns)
696    (format t "~&~v@t~s" indent n)))
697
698(defun show-fgn (node)
699  (format t "~&~s (~d) {~a}" (type-of node) (fgn-id node) (mapcar #'fgn-id (fgn-inedges node)))
700  (show-vinsns node 2)
701  (terpri)
702  (terpri))
703
704(defun dfs-walk (fgns &key
705                      process-before process-after
706                      process-succ-before process-succ-after)
707  (labels ((dfs (node)
708             (when process-before
709               (funcall process-before node))
710             (setf (fgn-visited node) t)
711             (when (typep node 'jumpnode)
712               (let* ((outedge (jumpnode-outedge node)))
713                 (unless (fgn-visited outedge)
714                   (when process-succ-before
715                     (funcall process-succ-before outedge))
716                   (dfs outedge)
717                   (when process-succ-after
718                     (funcall process-succ-after outedge))))
719               (when (typep node 'condnode)
720                 (let* ((branchedge (branch-target-node
721                                     (condnode-condbranch node))))
722                   (unless (fgn-visited branchedge)
723                     (when process-succ-before
724                       (funcall process-succ-before branchedge))
725                     (dfs branchedge)
726                     (when process-succ-after
727                       (funcall process-succ-after branchedge))))))
728             (when process-after
729               (funcall process-after node))))
730    (dolist (n fgns)
731      (setf (fgn-visited n) nil))
732    (dfs (car fgns))))
733
734(defun dfs-postorder (fgns)
735  (let* ((n (length fgns))
736         (v (make-array n))
737         (p -1)
738         (process-after #'(lambda (node)
739                            (setf (svref v (incf p)) node))))
740    (declare (fixnum p) (dynamic-extent process-after))
741    (dfs-walk fgns :process-after process-after)
742    v))
743
744;;; This generally only gives a meaningful result if pass 2 of the
745;;; compiler has been compiled in the current session.
746;;; TODO (maybe): keep track of the "expected missing vinsns" for
747;;; each backend, call this function after compiling pass 2.  That's
748;;; a little weird, since it'd require modifying backend X whenever
749;;; backend Y changes, but it's probably better than blowing up when
750;;; compiling user code.
751(defun missing-vinsns (&optional (backend *target-backend*))
752  (let* ((missing ()))
753    (maphash #'(lambda (name info)
754                 (unless (cdr info)
755                   (push name missing)))
756             (backend-p2-vinsn-templates backend))
757    missing))
758                     
759(provide "VINSN")
Note: See TracBrowser for help on using the repository browser.