source: branches/arm/compiler/vinsn.lisp @ 13955

Last change on this file since 13955 was 13955, checked in by gb, 9 years ago

arm-misc.lisp: Need xchgl for ARM (used in futex-based locking.)
l0-misc.lisp: ROOM and aux functions: no tsp on ARM
vinsn.lisp: rename :conditional attribute to :predicatable.
arm-vinsns.lisp, arm2.lisp: replace COPY-FPR with all 4 single/double
variants. Use :predicatable attribute to avoid some conditional branches.
arm-asm.lisp, arm-disassemble.lisp: add, fix some instruction definitions.

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