source: trunk/source/compiler/vinsn.lisp @ 15706

Last change on this file since 15706 was 15606, checked in by gb, 7 years ago

This is a work-in-progress; there will need to be new binaries
and similar changes for other architectures.

compiler/nx2.lisp: do late constant-folding on comparisons. (This depends

on being able to use operators for T and NIL in the backend; since backends
don't necessarily support that, check first.)

compiler/optimizers.lisp: bind temporaries for 3-arg numeric comparisons.

compiler/vinsn.lisp: do dead-code elimination at the vinsn level. Because

of the way that "aligned labels" work on x86, introduce an :align vinsn
attribute. Add/change some utilities for finding next/previous vinsn, etc.

compiler/X86/x862.lisp: Handle operators for T/NIL. Peephole optimize

things like (if (let ...)) where the LET returns a constant value and
we need to discard some words from the stack.

compiler/X86/X8632/x8632-arch.lisp:
compiler/X86/X8664/x8664-arch.lisp: Bump image version

compiler/X86/X8632/x8632-vinsns.lisp:
compiler/X86/X8664/x8664-vinsns.lisp: EMIT-ALIGNED-LABEL has :align

attribute

level-0/l0-hash.lisp: Don't assume that GC maintains weak-deletions; do

assume that it maintains count/deleted-count, so lock-based code adjusts
those slots atomically.

level-0/l0-misc.lisp: We don't want to use futexes (at least not instead

of spinlocks.)

level-0/X86/x86-misc.lisp: %ATOMIC-INCF-NODE needs to pause while spinning.

(Note that a locked ADD may be faster on x86, but wouldn't return a
meaningful value and some callers expect it to.)

level-1/l1-clos-boot.lisp: no more DESTRUCTURE-STATE.
level-1/l1-files.lisp: indentation change
level-1/l1-utils.lisp: no more DESTRUCTURE-STATE.
level-1/linux-files.lisp: UNSETENV

lib/hash.lisp: no need to %NORMALIZE-HASH-TABLE-COUNT.
lib/macros.lisp: no more DESTRUCTURE-STATE.

library/lispequ.lisp: no more DESTRUCTURE-STATE.

lisp-kernel/gc-common.c: decrement count when removing weak key from

hash vector; increment deleted-count if not lock-free.

lisp-kernel/x86-constants32.h:
lisp-kernel/x86-constants64.h: bump current, max image versions

lisp-kernel/linuxx8632/Makefile:
lisp-kernel/linuxx8664/Makefile: don't define USE_FUTEX.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 34.5 KB
RevLine 
[6]1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
[13067]3;;;   Copyright (C) 2009 Clozure Associates
[6]4;;;   Copyright (C) 1994-2001 Digitool, Inc
[13066]5;;;   This file is part of Clozure CL. 
[6]6;;;
[13066]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
[6]9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
[13066]10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
[6]11;;;   conflict, the preamble takes precedence. 
12;;;
[13066]13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
[6]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)
[15022]79  (gprs-read 0)
80  (fprs-read 0)
[6]81)
82
83(def-standard-initial-binding *vinsn-freelist* (make-dll-node-freelist))
84
85(defun make-vinsn (template)
86  (let* ((vinsn (alloc-dll-node *vinsn-freelist*)))
87    (loop
[15022]88      ;; Sometimes, the compiler seems to return its node list
89      ;; to the freelist without first removing the vinsn-labels in it.
90      #-bootstrapped (when (and (typep vinsn 'vinsn)
91                                (not (> (uvsize vinsn) 8)))
92                       (setf (pool.data *vinsn-freelist*) nil)
93                       (setq vinsn nil))
[6]94      (if (or (null vinsn) (typep vinsn 'vinsn)) (return))
95      (setq vinsn (alloc-dll-node *vinsn-freelist*)))
96    (if vinsn
97      (progn
98        (setf (vinsn-template vinsn) template
99              (vinsn-variable-parts vinsn) nil
[363]100              (vinsn-annotation vinsn) nil
101              (vinsn-gprs-set vinsn) 0
[15022]102              (vinsn-fprs-set vinsn) 0
103              (vinsn-gprs-read vinsn) 0
104              (vinsn-fprs-read vinsn) 0)
[6]105        vinsn)
106      (%make-vinsn template))))
107
108(eval-when (:load-toplevel :execute)
109(defstruct (vinsn-label (:include dll-node)
110                        (:print-function print-vinsn-label)
111                        (:predicate %vinsn-label-p)
112                        (:constructor %make-vinsn-label (id)))
113  id
114  refs                                  ; vinsns in which this label appears as an operand
115  info                                  ; code-generation stuff
116)
117)
118
119(def-standard-initial-binding *vinsn-label-freelist* (make-dll-node-freelist))
120
121(defun make-vinsn-label (id)
122  (let* ((lab (alloc-dll-node *vinsn-label-freelist*)))
123    (if lab
124      (progn
125        (setf (vinsn-label-id lab) id
126              (vinsn-label-refs lab) nil
127              (vinsn-label-info lab) nil)
128        lab)
129      (%make-vinsn-label id))))
130
131; "Real" labels have fixnum IDs.
132(defun vinsn-label-p (l)
133  (if (%vinsn-label-p l) 
134    (typep (vinsn-label-id l) 'fixnum)))
135
136
137(defun print-vinsn-label (l s d)
138  (declare (ignore d))
139  (print-unreadable-object (l s :type t)
140    (format s "~d" (vinsn-label-id l))))
141
142;;; Notes are attached to (some) vinsns.  They're used to attach
143;;; semantic information to an execution point.  The vinsn
144;;; points to the note via its LABEL-ID; the note has a backpointer to
145;;; the vinsn.
146
147(defstruct (vinsn-note
148            (:constructor %make-vinsn-note)
149            (:print-function print-vinsn-note))
150  (label (make-vinsn-label nil))
151  (peer nil :type (or null vinsn-note))
152  (class nil)
153  (info nil :type (or null simple-vector)))
154
155
156(defun print-vinsn-note (n s d)
157  (declare (ignore d))
158  (print-unreadable-object (n s :type t)
159    (format s "~d" (vinsn-note-class n))
160    (let* ((info (vinsn-note-info n)))
161      (when info (format s " / ~S" info)))))
162 
163(defun make-vinsn-note (class info)
164  (let* ((n (%make-vinsn-note :class class :info (if info (apply #'vector info))))
165         (lab (vinsn-note-label n)))
166    (setf (vinsn-label-id lab) n)
167    n))
168
169(defun close-vinsn-note (n)
170  (let* ((end (%make-vinsn-note :peer n)))
171    (setf (vinsn-label-id (vinsn-note-label end)) end
172          (vinsn-note-peer end) n
173          (vinsn-note-peer n) end)
174    end))
175       
176
177(defun vinsn-vreg-description (value spec)
178  (case (cadr spec)
179    ((:u32 :s32 :u16 :s16 :u8 :s8 :lisp :address :imm)
180     (let* ((mode (if (typep value 'fixnum)
181                    (get-regspec-mode value))))
182       (if (and mode (not (eql 0 mode)))
183         (list (hard-regspec-value value)
184               (car (rassoc mode *mode-name-value-alist* :test #'eq)))
185         value)))
186    (t value)))
187
188(defun collect-vinsn-variable-parts (v start n &optional specs)
189  (declare (fixnum start n))
190  (let* ((varparts (vinsn-variable-parts v)))
191    (when varparts
192      (let* ((head (cons nil nil))
193             (tail head))
194        (declare (dynamic-extent head) (cons head tail))
195        (do* ((j start (1+ j))
196              (i 0 (1+ i)))
197             ((= i n) (cdr head))
198          (declare (fixnum i j))
199          (setq tail (cdr (rplacd tail (cons (vinsn-vreg-description (svref varparts j) (pop specs)) nil)))))))))
200
201     
202(defun collect-vinsn-results (v)
203  (let* ((template (vinsn-template v))
204         (result-specs (vinsn-template-result-vreg-specs template)))
205    (collect-vinsn-variable-parts v 0 (length result-specs) result-specs)))
206
207(defun collect-vinsn-arguments (v)
208  (let* ((template (vinsn-template v))
209         (arg-specs (vinsn-template-argument-vreg-specs template)))
210    (collect-vinsn-variable-parts v
211                                  (- (length (vinsn-template-result-vreg-specs template)) 
212                                     (vinsn-template-nhybrids template))
213                                  (length arg-specs)
214                                  arg-specs)))
215
216(defun collect-vinsn-temps (v)
217  (let* ((template (vinsn-template v)))
218    (collect-vinsn-variable-parts v 
219                                  (+
220                                   (length (vinsn-template-result-vreg-specs template)) 
221                                   (length (vinsn-template-argument-vreg-specs template)))
222                                  (length (vinsn-template-temp-vreg-specs template)))))
223
224(defun template-infix-p (template)
225  (declare (ignore template))
226  nil)
227
228(defun print-vinsn (v stream d)
229  (declare (ignore d))
230  (let* ((template (vinsn-template v))
231         (results (collect-vinsn-results v))
232         (args (collect-vinsn-arguments v))
233         (opsym (if (cdr results) :== :=))
234         (infix (and (= (length args) 2) (template-infix-p template)))
235         (opname (vinsn-template-name template)))
236    (print-unreadable-object (v stream)
237      (if results (format stream "~A ~S " (if (cdr results) results (car results)) opsym))
238      (if infix
239        (format stream "~A ~A ~A" (car args) opname (cadr args))
240        (format stream "~A~{ ~A~}" opname args))
241      (let* ((annotation (vinsn-annotation v)))
242        (when annotation
243          (format stream " ||~a|| " annotation))))))
[15606]244
245(eval-when (:compile-toplevel :load-toplevel :execute)
[6]246(defparameter *known-vinsn-attributes*
247  '(
248    :jump                               ; an unconditional branch
249    :branch                             ; a conditional branch
250    :call                               ; a jump that returns
[15606]251    :align                              ; aligns FOLLOWING label
[6]252    :subprim-call                       ; A subprimitive call; bashes some volatile registers
253    :jumpLR                             ; Jumps to the LR, possibly stopping off at a function along the way.
254    :lrsave                             ; saves LR in LOC-PC
255    :lrrestore                          ; restores LR from LOC-PC
256    :lispcontext                        ; references lisp frame LOC-PC, FN, and entry VSP
257    :node                               ; saves/restores a node value in stack-like memory
258    :word                               ; saves/restores an unboxed word in stack-like memory
259    :doubleword                         ; saves/restores an unboxed doubleword (fp-reg) in stack-like memory
260    :vsp                                ; uses the vsp to save/restore
261    :tsp                                ; uses the tsp to save/restore
262    :csp                                ; uses sp to save/restore
263    :push                               ; saves something
264    :pop                                ; restores something
265    :multiple                           ; saves/restores multiple nodes/words/doublewords
266    :ref                                ; references memory
267    :set                                ; sets memory
268    :outgoing-argument                  ; e.g., pushed as an argument, not to avoid clobbering
269    :xref                               ; makes some label externally visible
270    :jump-unknown                       ; Jumps, but we don't know where ...
[3241]271    :constant-ref
272    :sets-cc                            ; vinsn sets condition codes based on result
[11289]273    :discard                            ; adjusts a stack pointer
[14119]274    :sp
275    :predicatable                       ; all instructions can be predicated, no instructions set or test condition codes.
[14472]276    :sets-lr                            ; uses the link register, if there is one.
[15606]277    )))
[6]278
279(defparameter *nvp-max* 10 "size of *vinsn-varparts* freelist elements")
280(def-standard-initial-binding *vinsn-varparts* (%cons-pool))
281
282(defun alloc-varparts-vector ()
283  (without-interrupts
284   (let* ((v (pool.data *vinsn-varparts*)))
285     (if v
286       (progn
287         (setf (pool.data *vinsn-varparts*)
288               (svref v 0))
289          (%init-misc 0 v)
290         v)
291       (make-array (the fixnum *nvp-max*) :initial-element 0)))))
292
293(defun free-varparts-vector (v)
294  (without-interrupts
295   (setf (svref v 0) (pool.data *vinsn-varparts*)
296         (pool.data *vinsn-varparts*) v)
297   nil))
298
299(defun elide-vinsn (vinsn)
300  (let* ((nvp (vinsn-template-nvp (vinsn-template vinsn)))
301         (vp (vinsn-variable-parts vinsn)))
302    (dotimes (i nvp)
303      (let* ((v (svref vp i)))
304        (when (typep v 'lreg)
305          (setf (lreg-defs v) (delete vinsn (lreg-defs v)))
306          (setf (lreg-refs v) (delete vinsn (lreg-refs v))))))
307    (free-varparts-vector vp)
308    (remove-dll-node vinsn)))
309   
310(defun encode-vinsn-attributes (attribute-list)
311  (flet ((attribute-weight (k)
312           (let* ((pos (position k *known-vinsn-attributes*)))
313             (if pos (ash 1 pos) (error "Unknown vinsn attribute: ~s" k)))))
314    (let* ((attr 0))
315      (declare (fixnum attr))
316      (dolist (a attribute-list attr)
317        (setq attr (logior attr (the fixnum (attribute-weight a))))))))
318
319
320(defun %define-vinsn (backend vinsn-name results args temps body)
[3163]321  (funcall (backend-define-vinsn backend)
[3165]322           backend
[3163]323           vinsn-name
324           results
325           args
326           temps
327           body))
[6]328
[3163]329
330;; Fix the opnum's in the vinsn-template-body to agree with the
331;; backend's opcode hash table.
[6]332(defun fixup-vinsn-template (orig-template opcode-hash)
333  (let ((template (cdr orig-template)))
[1398]334    (when template
335      (unless (vinsn-template-p template)
336        (setq template (require-type template 'vinsn-template)))
337      (let ((new-opcode-alist nil)
338            (changes nil)
339            (opcode-alist (vinsn-template-opcode-alist template)))
340        ;; this is patterned after ppc2-expand-vinsn
341        (labels ((walk-form (f)
342                   (unless (atom f)
343                     (if (fixnump (car f))
344                       (got-one f)
345                       (dolist (subform (cdr f))
346                         (walk-form subform)))))
347                 (got-one (f)
348                   (let* ((old-opcode (car f))
349                          (name (cdr (assq old-opcode opcode-alist)))
350                          (new-opcode (and name (gethash name opcode-hash))))
351                     (unless new-opcode
352                       (cerror "Continue" "Can't find new opcode number ~
[6]353                                   for ~s in ~s" (car f) template))
[1398]354                     (setf (assq new-opcode new-opcode-alist) name)
355                     (unless (eq new-opcode old-opcode)
356                       (push (cons f new-opcode) changes)))))
357          (mapc #'walk-form (vinsn-template-body template))
358          (without-interrupts
359           (dolist (change changes)
360             (setf (caar change) (cdr change)))
361           (setf (vinsn-template-opcode-alist template)
362                 new-opcode-alist))))
363      orig-template)))
[6]364
365(defun fixup-vinsn-templates (templates opcode-hash-table)
366  (maphash #'(lambda (name template)
367               (declare (ignore name))
368               (fixup-vinsn-template template opcode-hash-table))
369           templates))
[15022]370
371
372
373
[3163]374;;; Could probably split this up and do some arg checking at macroexpand time.
[6]375(defun match-template-vregs (template vinsn supplied-vregs)
376  (declare (list supplied-vregs))
377  (let* ((nsupp (length supplied-vregs))
378         (results&args (vinsn-template-results&args template))
379         (nra (length results&args))
380         (temp-specs (vinsn-template-temp-vreg-specs template))
381         (ntemps (length temp-specs))
382         (nvp (vinsn-template-nvp template))
383         (vp (alloc-varparts-vector))
384         (*available-backend-node-temps* *available-backend-node-temps*)
385         (*available-backend-fp-temps* *available-backend-fp-temps*)
386         (*available-backend-imm-temps* *available-backend-imm-temps*)
387         (*available-backend-crf-temps* *available-backend-crf-temps*))
388    (declare (fixnum nvp ntemps nsupp)
[9879]389             (list temp-specs))
[6]390    (unless (= nsupp nra)
391      (error "Vinsn ~A expects ~D result/argument specs, received ~D ."
392             (vinsn-template-name template) nra nsupp))
393    (do* ((i 0 (1+ i))
394          (supp supplied-vregs (cdr supp))
395          (spec results&args (cdr spec)))
396         ((null supp))
397      (declare (fixnum i) (list spec supp))
398      (setf (svref vp i) (match-vreg (car supp) (cadar spec) vinsn vp i)))
399    ;; Allocate some temporaries.
400    (do* ((i (- nvp ntemps) (1+ i))
401          (temps temp-specs (cdr temps)))
402         ((null temps) vp)
403      (declare (fixnum i))
[6474]404      (let* ((spec (cadar temps)))
405        (if (and (consp spec) (eq (car spec) :label))
406          (let* ((label (aref *backend-labels* (cadr spec))))
407            (push vinsn (vinsn-label-refs label))
408            (setf (svref vp i) label))
409          (let* ((lreg (allocate-temporary-vreg (car temps)))
410                 (class (hard-regspec-class lreg))
411                 (value (hard-regspec-value lreg)))
412            (when value
413              (case class
414                (#.hard-reg-class-gpr (note-vinsn-sets-gpr vinsn value))
[14834]415                (#.hard-reg-class-fpr (note-vinsn-sets-fpr-lreg vinsn lreg))))
[6474]416            (setf (svref vp i) lreg)
417            (pushnew vinsn (lreg-defs lreg))
418            (pushnew vinsn (lreg-refs lreg))))))))
[6]419
[3163]420;;; "spec" is (<name> <class>).
421;;;  <class> is keyword or (<keyword> <val>)
[6]422(defun allocate-temporary-vreg (spec)
423  (setq spec (cadr spec))
424  (let* ((class (if (atom spec) spec (car spec)))
425         (value (if (atom spec) nil (cadr spec))))
426    (if value
427      (ecase class
428        (:crf (make-wired-lreg (use-crf-temp value) :class hard-reg-class-crf))
[368]429        ((:u8 :s8 :u16 :s16 :u32 :s32 :u64 :s64) 
[6]430         (make-wired-lreg (use-imm-temp value)
431                          :class hard-reg-class-gpr
432                          :mode (gpr-mode-name-value class)))
433        (:lisp (make-wired-lreg 
434                (use-node-temp value) 
435                :class hard-reg-class-gpr
[14972]436                :mode hard-reg-class-gpr-mode-node))
437        (:double-float (let* ((lreg (make-wired-lreg
438                                     value
439                                     :class hard-reg-class-fpr
440                                     :mode hard-reg-class-fpr-mode-double)))
441                         (use-fp-reg lreg)
442                         lreg))
443        (:single-float (let* ((lreg (make-wired-lreg
444                                     value
445                                     :class hard-reg-class-fpr
446                                     :mode hard-reg-class-fpr-mode-single)))
447                         (use-fp-reg lreg)
448                         lreg)))
[6]449      (ecase class
450        ((:imm :wordptr) 
451         (make-unwired-lreg
452          (if (= *available-backend-imm-temps* 0) (select-node-temp) (select-imm-temp))
453              :class hard-reg-class-gpr
454              :mode hard-reg-class-gpr-mode-node)) 
[14972]455        ((:u8 :s8 :u16 :s16 :u32 :s32 :u64 :s64 :address) 
[6]456         (make-unwired-lreg (select-imm-temp)
457                            :class hard-reg-class-gpr
458                            :mode (gpr-mode-name-value class)))
[14834]459        (:double-float
460         (make-unwired-lreg (select-fp-temp :double-float)
461                            :class hard-reg-class-fpr
462                            :mode hard-reg-class-fpr-mode-double))
463        (:single-float
464         (make-unwired-lreg (select-fp-temp :single-float)
465                            :class hard-reg-class-fpr
466                            :mode hard-reg-class-fpr-mode-double))
[6]467        (:lisp 
468         (make-unwired-lreg 
469          (select-node-temp) 
470          :class hard-reg-class-gpr
471          :mode hard-reg-class-gpr-mode-node))
472        (:crf 
473         (make-unwired-lreg (select-crf-temp) :class hard-reg-class-crf))))))
474
475
476
477(defun select-vinsn (template-or-name template-hash vregs)
478  (let* ((template (need-vinsn-template template-or-name template-hash))
479         (vinsn (make-vinsn template)))
480    (setf (vinsn-variable-parts vinsn) (match-template-vregs template vinsn vregs))
481    vinsn))
482
483(defun %emit-vinsn (vlist name vinsn-table &rest vregs)
484  (append-dll-node (select-vinsn name vinsn-table vregs) vlist))
485
486(defun varpart-matches-reg (varpart-value class regval spec)
487  (setq spec (if (atom spec) spec (car spec)))
488  (and
489   (or
490    (and (eq class hard-reg-class-fpr)
491         (memq spec '(:single-float :double-float)))
492    (and (eq class hard-reg-class-gpr)
493         (memq spec '(:u32 :s32 :u16 :s16 :u8 :s8 :lisp :address :imm))))
494   (eq (hard-regspec-value varpart-value) regval)))
495
[15022]496(defun vinsn-refs-reg-p (element reg)
497  (if (typep element 'vinsn)
498    (if (vinsn-attribute-p element :call)
499      t
500      (let* ((class (hard-regspec-class reg))
501             (value (hard-regspec-value reg)))
502        (if (eq class hard-reg-class-gpr)
503          (logbitp value (vinsn-gprs-read element))
504          (if (eq class hard-reg-class-fpr)
505            ;; The FPR is logically read in the vinsn if it or any
506            ;; conflicting FPR is physically read in the vinsn.
507            (logtest (fpr-mask-for-vreg reg) (vinsn-fprs-read element))))))))
508
[6]509(defun vinsn-sets-reg-p (element reg)
510  (if (typep element 'vinsn)
511    (if (vinsn-attribute-p element :call)
512      t
513      (let* ((class (hard-regspec-class reg))
514             (value (hard-regspec-value reg)))
515        (if (eq class hard-reg-class-gpr)
516          (logbitp value (vinsn-gprs-set element))
517          (if (eq class hard-reg-class-fpr)
[14846]518            ;; The FPR is logically set in the vinsn if it or any
519            ;; conflicting FPR is physically set in the vinsn.
520            (logtest (fpr-mask-for-vreg reg) (vinsn-fprs-set element))))))))
[6]521
522;;; Return bitmasks of all GPRs and all FPRs set in the vinsns between
523;;; START and END, exclusive.  Any :call vinsn implicitly clobbers
524;;; all registers.
525(defun regs-set-in-vinsn-sequence (start end)
526  (let* ((gprs-set 0)
527         (fprs-set 0))
[14258]528    (do* ((element (dll-node-succ start) (dll-node-succ element)))
[14834]529         ((eq element end) (values gprs-set fprs-set))
[6]530      (if (typep element 'vinsn)
531        (if (vinsn-attribute-p element :call)
532          (return (values #xffffffff #xffffffff))
[14958]533          (setq gprs-set (logior gprs-set (vinsn-gprs-set element))
534                fprs-set (logior fprs-set (vinsn-fprs-set element))))))))
[15022]535
536
[6]537     
[15022]538;;; If any vinsn between START and END (exclusive) sets REG, return
539;;; that vinsn; otherwise, return NIL.
[6]540(defun vinsn-sequence-sets-reg-p (start end reg)
[14258]541  (do* ((element (dll-node-succ start) (dll-node-succ element)))
[6]542       ((eq element end))
543    (if (vinsn-sets-reg-p element reg)
[15022]544      (return element))))
[6]545       
[15022]546;;; If any vinsn between START and END (exclusive) refs REG, return
547;;; the last such vinsn; otherwise, return NIL.
548(defun vinsn-sequence-refs-reg-p (start end reg)
549  (do* ((element (dll-node-pred end) (dll-node-pred element)))
550       ((eq element start))
551    (if (vinsn-refs-reg-p element reg)
552      (return element))))
[6]553
[15022]554
[11711]555;;; Return T if any vinsn between START and END (exclusive) has all
[15076]556;;; attributes set in ATTR set.
[11711]557(defun %vinsn-sequence-has-attribute-p (start end attr)
[14258]558  (do* ((element (dll-node-succ start) (dll-node-succ element)))
[11711]559       ((eq element end))
560    (when (typep element 'vinsn)
[15022]561      (when (eql attr (logand (vinsn-template-attributes (vinsn-template element)) attr))
[11711]562        (return t)))))
563
[15076]564;;; Return T if any vinsn between START and END (exclusive) has some
565;;; some attributes set in attr set.
566(defun %vinsn-sequence-has-some-attribute-p (start end attr)
567  (do* ((element (dll-node-succ start) (dll-node-succ element)))
568       ((eq element end))
569    (when (typep element 'vinsn)
570      (when (logtest attr (vinsn-template-attributes (vinsn-template element)))
571        (return t)))))
572
[11711]573(defmacro vinsn-sequence-has-attribute-p (start end &rest attrs)
574  `(%vinsn-sequence-has-attribute-p ,start ,end ,(encode-vinsn-attributes attrs)))
575
[15076]576(defmacro vinsn-sequence-has-some-attribute-p (start end &rest attrs)
577  `(%vinsn-sequence-has-some-attribute-p ,start ,end ,(encode-vinsn-attributes attrs)))
578
[15022]579;;; Return T iff vinsn is between START and END (exclusive).
580(defun vinsn-in-sequence-p (vinsn start end)
581  (do* ((element (dll-node-succ start) (dll-node-succ element)))
582       ((eq element end))
583    (when (eq vinsn element)
584      (return t))))
585
[15606]586(defun last-vinsn (seg &optional (after seg))
[15022]587  ;; Try to find something that isn't a SOURCE-NOTE.  Go ahead.  I dare you.
588  (do* ((element (dll-header-last seg) (dll-node-pred element)))
[15606]589       ((eq element after))               ;told ya!
[15022]590    (when (typep element 'vinsn)
591      (return element))))
592
593
[6]594;;; Flow-graph nodes (FGNs)
595
596(defstruct (fgn (:include dll-header))
597  (id 0 :type unsigned-byte)
598  (inedges ())                          ; list of nodes which reference this node
599  (visited nil)                         ; Boolean
600)
601
602
603
[3163]604;;; FGNs which don't terminate with an "external jump"
605;;; (jump-return-pc/jump-subprim, etc) jump to their successor, either
606;;; explicitly or by falling through.  We can introduce or remove
607;;; jumps when linearizing the program.
[6]608(defstruct (jumpnode (:include fgn)
609                     (:constructor %make-jumpnode (id)))
610  (outedge)                             ; the FGN we jump/fall in to.
611)
612
613(defun make-jumpnode (id)
614  (init-dll-header (%make-jumpnode id)))
615   
[3163]616;;; A node that ends in a conditional branch, followed by an implicit
617;;; or explicit jump.  Keep track of the conditional branch and the
618;;; node it targets.
[6]619(defstruct (condnode (:include jumpnode)
620                     (:constructor %make-condnode (id)))
621  (condbranch)                          ; the :branch vinsn
622  (branchedge)                          ; the FGN it targets
623)
624
625(defun make-condnode (id)
626  (init-dll-header (%make-condnode id)))
627         
[3163]628;;; A node that terminates with a return i.e., a jump-return-pc or
629;;; jump-subprim.
[6]630(defstruct (returnnode (:include fgn)
631                       (:constructor %make-returnnode (id)))
632)
633
634(defun make-returnnode (id)
635  (init-dll-header (%make-returnnode id)))
636
637;;; Some specified attribute is true.
638(defun %vinsn-attribute-p (vinsn mask)
639  (declare (fixnum mask))
640  (if (vinsn-p vinsn)
641    (let* ((template (vinsn-template vinsn)))
642      (not (eql 0 (logand mask (the fixnum (vinsn-template-attributes template))))))))
643
644;;; All specified attributes are true.
645(defun %vinsn-attribute-= (vinsn mask)
646  (declare (fixnum mask))
647  (if (vinsn-p vinsn)
648    (let* ((template (vinsn-template vinsn)))
649      (= mask (the fixnum (logand mask (the fixnum (vinsn-template-attributes template))))))))
650 
651(defmacro vinsn-attribute-p (vinsn &rest attrs)
652  `(%vinsn-attribute-p ,vinsn ,(encode-vinsn-attributes attrs)))
653
654(defmacro vinsn-attribute-= (vinsn &rest attrs)
655  `(%vinsn-attribute-= ,vinsn ,(encode-vinsn-attributes attrs)))
656
[3163]657;;; Ensure that conditional branches that aren't followed by jumps are
658;;; followed by (jump lab-next) @lab-next.  Ensure that JUMPs and
659;;; JUMPLRs are followed by labels.  It's easiest to do this by
660;;; walking backwards.  When we're all done, labels will mark the
661;;; start of each block.
[6]662
663(defun normalize-vinsns (header)
664  (do* ((prevtype :label currtype)
665        (current (dll-header-last header) (dll-node-pred current))
666        (currtype nil))
667       ((eq current header)
668        (unless (eq prevtype :label)
669          (insert-dll-node-after
670           (aref *backend-labels* (backend-get-next-label))
671           current)))
672    (setq currtype (cond ((vinsn-label-p current) :label)
673                         ((vinsn-attribute-p current :branch) :branch)
674                         ((vinsn-attribute-p current :jump) :jump)
675                         ((vinsn-attribute-p current :jumplr) :jumplr)))
676    (case currtype
677      ((:jump :jumplr)
678       (unless (eq prevtype :label)
679         (let* ((lab (aref *backend-labels* (backend-get-next-label))))
680           (insert-dll-node-after lab current))))
681      (:branch
[7941]682       (unless (eq prevtype :jump)
683         (let* ((lab
684                 (if (eq prevtype :label)
685                   (dll-node-succ current)
686                   (aref *backend-labels* (backend-get-next-label))))
687                (jump (select-vinsn "JUMP" *backend-vinsns* (list lab))))
688           (unless (eq prevtype :label)
689             (insert-dll-node-after lab current))
690           (insert-dll-node-after jump current))))
[6]691      ((nil)
692       (if (eq prevtype :label)
693         (let* ((lab (dll-node-succ current)))
694           (when (vinsn-label-p lab)
[7941]695             (insert-dll-node-after
696              (select-vinsn "JUMP" *backend-vinsns* (list lab))
[6]697              current))))))))
698
699
700;;; Unless the header is empty, remove the last vinsn and all preceding
701;;; vinsns up to and including the preceding label.  (Since the vinsns
702;;; have been normalized, there will always be a preceding label.)
703;;; Return the label and the last vinsn, or (values nil nil.)
704(defun remove-last-basic-block (vinsns)
705  (do* ((i 1 (1+ i))
706        (current (dll-header-last vinsns) (dll-node-pred current)))
707       ((eq current vinsns) (values nil nil))
708    (declare (fixnum i))
709    (if (vinsn-label-p current)
710      (return (remove-dll-node current i)))))
711
712;;; Create a flow graph from vinsns and return the entry node.
713(defun create-flow-graph (vinsns)
714  (let* ((nodes ()))
715    (flet ((label->fgn (label) (dll-node-pred label)))
716      (loop
717          (multiple-value-bind (label last) (remove-last-basic-block vinsns)
718            (when (null label) (return))
719            (let* ((id (vinsn-label-id label))
720                   (node (if (vinsn-attribute-p last :jumpLR)
721                           (make-returnnode id)
722                           (if (vinsn-attribute-p (dll-node-pred last) :branch)
723                             (make-condnode id)
724                             (make-jumpnode id)))))
[9879]725              (declare (fixnum id))
[6]726              (insert-dll-node-after label node last)
727              (push node nodes))))
728      (dolist (node nodes nodes)
729        (if (typep node 'jumpnode)
730          (let* ((jump (dll-header-last node))
731                 (jmptarget (branch-target-node jump)))
732            (setf (jumpnode-outedge node) jmptarget)
733            (pushnew node (fgn-inedges jmptarget))
734            (if (typep node 'condnode)  ; a subtype of jumpnode
735              (let* ((branch (dll-node-pred jump))
736                     (branchtarget (branch-target-node branch)))
737                (setf (condnode-condbranch node) branch)
738                (pushnew node (fgn-inedges branchtarget))))))))))
739 
740                         
741(defun delete-unreferenced-labels (labels)
742  (delete #'(lambda (l)
743              (unless (vinsn-label-refs l)
744                (when (vinsn-label-succ l)
745                  (remove-dll-node l))
746                t)) labels :test #'funcall))
747
748(defun branch-target-node (v)
749  (dll-node-pred (svref (vinsn-variable-parts v) 0)))
750
[7941]751(defun replace-label-refs (vinsn old-label new-label)
752  (let ((vp (vinsn-variable-parts vinsn)))
753    (dotimes (i (length vp))
754      (when (eq (svref vp i) old-label)
755        (setf (svref vp i) new-label)))))
756 
757;;; Try to remove jumps/branches to jumps.
758(defun maximize-jumps (header)
759  (do* ((prev nil next)
760        (next (dll-header-first header) (dll-node-succ next)))
761       ((eq next header))
762    (when (and (vinsn-attribute-p next :jump)
763               (vinsn-label-p  prev))
764      (let* ((target (svref (vinsn-variable-parts next) 0)))
765        (unless (eq target prev)
766          (dolist (ref (vinsn-label-refs prev) (setf (vinsn-label-refs prev) nil))
767            (replace-label-refs ref prev target)
768            (push ref (vinsn-label-refs target))))))))
[6]769
[15606]770(defparameter *nx-do-dead-code-elimination* t)
771
772(defun eliminate-dead-code (header)
773  (when *nx-do-dead-code-elimination*
774    (let* ((eliding nil)
775           (won nil))
776      (do-dll-nodes (element header won)
777        ;; If a label, leave it.
778        (etypecase element
779          (vinsn-label
780           (when (typep (vinsn-label-id element) 'fixnum)
781             (if (vinsn-label-refs element)
782               (setq eliding nil))))
783          (vinsn
784           (when (vinsn-attribute-p element :align)
785             (let* ((next (vinsn-succ element)))
786               (when (and (typep next 'vinsn-label)
787                          (typep (vinsn-label-id next) 'fixnum)
788                          (not (null (vinsn-label-refs next))))
789                 (setq eliding nil))))
790           (cond (eliding
791                    (setq won t)
792                    (let* ((operands (vinsn-variable-parts element)))
793                      (dotimes (i (length operands) (elide-vinsn element))
794                        (let* ((op (svref operands i)))
795                          (when (typep op 'vinsn-label)
796                            (setf (vinsn-label-refs op)
797                                  (delete element (vinsn-label-refs op))))))))
798                   (t (setq eliding (vinsn-attribute-p element :jump))))))))))
799         
800
[6]801(defun optimize-vinsns (header)
[3163]802  ;; Delete unreferenced labels that the compiler might have emitted.
803  ;; Subsequent operations may cause other labels to become
804  ;; unreferenced.
[80]805  (let* ((labels (collect ((labs)) 
[6]806                   (do-dll-nodes (v header)
807                     (when (vinsn-label-p v) (labs v)))
808                   (labs))))
809    ;; Look for pairs of adjacent, referenced labels.
810    ;; Merge them together (so that one of them becomes unreferenced.)
811    ;; Repeat the process until no pairs are found.
812    (do* ((repeat t))
813         ((not repeat))
814      (setq repeat nil 
815            labels (delete-unreferenced-labels labels))
816      (dolist (l labels)
817        (let* ((succ (vinsn-label-succ l)))
818          (when (vinsn-label-p succ)
819            (backend-merge-labels l succ)
820            (setq repeat t)
821            (return)))))
[7941]822    (maximize-jumps header)
[6]823    (delete-unreferenced-labels labels)
[15606]824    ;;(normalize-vinsns header)
825    (eliminate-dead-code header)
[6]826  ))
827
828(defun show-vinsns (vinsns indent)
829  (do-dll-nodes (n vinsns)
830    (format t "~&~v@t~s" indent n)))
831
832(defun show-fgn (node)
833  (format t "~&~s (~d) {~a}" (type-of node) (fgn-id node) (mapcar #'fgn-id (fgn-inedges node)))
834  (show-vinsns node 2)
835  (terpri)
836  (terpri))
837
838(defun dfs-walk (fgns &key
839                      process-before process-after
840                      process-succ-before process-succ-after)
841  (labels ((dfs (node)
842             (when process-before
843               (funcall process-before node))
844             (setf (fgn-visited node) t)
845             (when (typep node 'jumpnode)
846               (let* ((outedge (jumpnode-outedge node)))
847                 (unless (fgn-visited outedge)
848                   (when process-succ-before
849                     (funcall process-succ-before outedge))
850                   (dfs outedge)
851                   (when process-succ-after
852                     (funcall process-succ-after outedge))))
853               (when (typep node 'condnode)
854                 (let* ((branchedge (branch-target-node
855                                     (condnode-condbranch node))))
856                   (unless (fgn-visited branchedge)
857                     (when process-succ-before
858                       (funcall process-succ-before branchedge))
859                     (dfs branchedge)
860                     (when process-succ-after
861                       (funcall process-succ-after branchedge))))))
862             (when process-after
863               (funcall process-after node))))
864    (dolist (n fgns)
865      (setf (fgn-visited n) nil))
866    (dfs (car fgns))))
867
868(defun dfs-postorder (fgns)
869  (let* ((n (length fgns))
870         (v (make-array n))
871         (p -1)
872         (process-after #'(lambda (node)
873                            (setf (svref v (incf p)) node))))
874    (declare (fixnum p) (dynamic-extent process-after))
875    (dfs-walk fgns :process-after process-after)
876    v))
[1992]877
[15606]878       
879(defun last-vinsn-unless-label (seg)
880  ;; Look at the last element(s) of seg.  If a vinsn-note,
881  ;; keep looking.  If a vinsn, return it; if a vinsn-label,
882  ;; return nil
883  (do* ((element (dll-header-last seg) (dll-node-pred element)))
884       ((eq element seg))
885    (etypecase element
886      (vinsn (return element))
887      (vinsn-label (if (typep (vinsn-label-id element) 'fixnum)
888                     (return nil))))))
889       
890
891
892
[1992]893;;; This generally only gives a meaningful result if pass 2 of the
894;;; compiler has been compiled in the current session.
895;;; TODO (maybe): keep track of the "expected missing vinsns" for
896;;; each backend, call this function after compiling pass 2.  That's
897;;; a little weird, since it'd require modifying backend X whenever
898;;; backend Y changes, but it's probably better than blowing up when
899;;; compiling user code.
900(defun missing-vinsns (&optional (backend *target-backend*))
901  (let* ((missing ()))
902    (maphash #'(lambda (name info)
903                 (unless (cdr info)
904                   (push name missing)))
905             (backend-p2-vinsn-templates backend))
906    missing))
[6]907                     
[83]908(provide "VINSN")
Note: See TracBrowser for help on using the repository browser.