| blob | 93c46945d6951f9866937c3b290010fd74527efa |
1 ;; address after which memory is allocated by the user, therefore not used for
2 ;; register allocation
3 ;; in programs, located in the SIXPIC_MEMORY_DIVIDE variable
4 (define memory-divide #f)
6 (define (interference-graph cfg)
8 (define (analyze-liveness cfg)
9 (define changed? #t)
10 (define (instr-analyze-liveness instr live-after)
11 (let ((live-before
12 (cond
13 ((call-instr? instr)
14 (let ((def-proc (call-instr-def-proc instr)))
15 (if (and (not (set-empty? live-after))
16 (not (set-equal?
17 (set-intersection
18 (def-procedure-live-after-calls def-proc)
19 live-after)
20 live-after)))
21 (begin
22 (set! changed? #t)
23 (set-union! (def-procedure-live-after-calls def-proc)
24 live-after)))
25 (let ((live
26 (set-union
27 (set-union-multi
28 (map (lambda (def-var)
29 (list->set
30 (value-bytes (def-variable-value def-var))))
31 (def-procedure-params def-proc)))
32 (set-diff
33 live-after
34 (list->set
35 (value-bytes (def-procedure-value def-proc)))))))
36 (if (bb? (def-procedure-entry def-proc))
37 (set-intersection
38 (bb-live-before (def-procedure-entry def-proc))
39 live)
40 live))))
41 ((return-instr? instr)
42 (let ((def-proc (return-instr-def-proc instr)))
43 (let ((live
44 (if (def-procedure? def-proc)
45 (def-procedure-live-after-calls def-proc)
46 (list->set (value-bytes def-proc)))))
47 (set! live-after live)
48 live)))
49 (else
50 (let* ((src1 (instr-src1 instr))
51 (src2 (instr-src2 instr))
52 (dst (instr-dst instr))
53 (use (if (byte-cell? src1)
54 (if (byte-cell? src2)
55 (set-add (new-set src1) src2)
56 (new-set src1))
57 (if (byte-cell? src2)
58 (new-set src2)
59 (new-empty-set))))
60 (def (if (byte-cell? dst)
61 (new-set dst)
62 (new-empty-set))))
63 (if #f
64 ;; (and (byte-cell? dst) ; dead instruction?
65 ;; (not (set-member? live-after dst))
66 ;; (not (and (byte-cell? dst) (byte-cell-adr dst))))
67 live-after
68 (set-union use
69 (set-diff live-after def))))))))
70 (instr-live-before-set! instr live-before)
71 (instr-live-after-set! instr live-after)
72 live-before))
73 (define (bb-analyze-liveness bb)
74 (let loop ((rev-instrs (bb-rev-instrs bb))
75 (live-after (set-union-multi
76 (map bb-live-before (bb-succs bb)))))
77 (if (null? rev-instrs)
78 (if (not (set-equal? live-after (bb-live-before bb)))
79 (begin (set! changed? #t)
80 (bb-live-before-set! bb live-after)))
81 (let* ((instr (car rev-instrs))
82 (live-before (instr-analyze-liveness instr live-after)))
83 (loop (cdr rev-instrs)
84 live-before)))))
85 (let loop ()
86 (if changed?
87 (begin (set! changed? #f)
88 (for-each bb-analyze-liveness (cfg-bbs cfg))
89 (loop)))))
91 (define all-live (new-empty-set))
92 (define (bb-interference-graph bb)
93 (define (interfere x y)
94 (if (not (set-member? (byte-cell-interferes-with y) x))
95 (begin (set-add! (byte-cell-interferes-with x) y)
96 (set-add! (byte-cell-interferes-with y) x))))
97 (define (interfere-pairwise live)
98 (set-union! all-live live) ;; TODO build the live set only once, if not a set already
99 (set-for-each ;; TODO for each cell in live, do the union of live, diff itself, if live is not a set, we win so we can iterate on something better than a hash table
100 ;; TODO since all true variables will be in the low numbers and all temps in the high numbers, we can have sparse bit vectors (if all below n is 0, don't store it) and save (or even have a bit vector that can store data by chunks, leaving empty space)
101 (lambda (x)
102 (set-for-each (lambda (y) (if (not (eq? x y)) (interfere x y)))
103 live))
104 live))
105 (define (instr-interference-graph instr)
106 (let ((dst (instr-dst instr)))
107 (if (byte-cell? dst)
108 (let ((src1 (instr-src1 instr))
109 (src2 (instr-src2 instr)))
110 (if (byte-cell? src1)
111 (begin (set-add! (byte-cell-coalesceable-with dst) src1)
112 (set-add! (byte-cell-coalesceable-with src1) dst)))
113 (if (byte-cell? src2)
114 (begin (set-add! (byte-cell-coalesceable-with dst) src2)
115 (set-add! (byte-cell-coalesceable-with src2) dst)))
116 (interfere-pairwise (set-add (instr-live-after instr) dst)))))
117 (interfere-pairwise (instr-live-before instr)))
118 (for-each instr-interference-graph (bb-rev-instrs bb)))
120 (pp analyse-liveness:)
121 (time (analyze-liveness cfg))
123 (pp interference-graph:)
124 (time (for-each bb-interference-graph (cfg-bbs cfg)))
126 all-live)
128 ;;-----------------------------------------------------------------------------
130 (define register-table (make-table))
131 (define (allocate-registers cfg)
132 (let ((all-live (interference-graph cfg))
133 (max-adr 0)) ; to know how much ram we need
135 (define (color byte-cell)
136 (let (;; (coalesce-candidates ; TODO right now, no coalescing is done
137 ;; (set-filter byte-cell-adr
138 ;; (set-diff (byte-cell-coalesceable-with byte-cell)
139 ;; (byte-cell-interferes-with byte-cell))))
140 )
141 ;; '
142 ;; (pp (list byte-cell: byte-cell;;;;;;;;;;;;;;;
143 ;; coalesce-candidates
144 ;; ; interferes-with: (byte-cell-interferes-with byte-cell)
145 ;; ; coalesceable-with: (byte-cell-coalesceable-with byte-cell)
146 ;; ))
148 (if #f #;(not (null? coalesce-candidates))
149 (let ((adr (byte-cell-adr (car (set->list coalesce-candidates))))) ;; TODO have as a set all along
150 (byte-cell-adr-set! byte-cell adr))
151 (let ((neighbours (byte-cell-interferes-with byte-cell)))
152 (let loop1 ((adr 0))
153 (if (and memory-divide ; the user wants his own zone
154 (>= adr memory-divide)) ; and we'd use it
155 (error "register allocation would cross the memory divide") ;; TODO fallback ?
156 (let loop2 ((lst (set->list neighbours))) ;; TODO keep using sets, but not urgent, it's not a bottleneck
157 (if (null? lst)
158 (begin (byte-cell-adr-set! byte-cell adr)
159 (if (not (string=? (byte-cell-name byte-cell)
160 "__tmp"))
161 (table-set!
162 register-table
163 (if (and (> adr #x5F) (< adr #xF60))
164 ;; not in bank 0
165 (+ adr #xa0)
166 adr)
167 (cons (byte-cell-name byte-cell)
168 (table-ref register-table
169 adr '())))))
170 (let ((x (car lst)))
171 (if (= adr (byte-cell-adr x))
172 (loop1 (+ adr 1))
173 (loop2 (cdr lst)))))))
174 (set! max-adr (max max-adr adr)))))))
176 (define (delete byte-cell1 neighbours)
177 (set-for-each (lambda (byte-cell2)
178 (set-remove! (byte-cell-interferes-with byte-cell2)
179 byte-cell1))
180 neighbours))
182 (define (undelete byte-cell1 neighbours)
183 (set-for-each (lambda (byte-cell2)
184 (set-add! (byte-cell-interferes-with byte-cell2)
185 byte-cell1))
186 neighbours))
188 (define (find-min-neighbours graph)
189 (let loop ((lst graph) (m #f) (byte-cell #f))
190 (if (null? lst)
191 byte-cell
192 (let* ((x (car lst))
193 (n (set-length (byte-cell-interferes-with x))))
194 (if (or (not m) (< n m))
195 (loop (cdr lst) n x)
196 (loop (cdr lst) m byte-cell))))))
198 (define (alloc-reg graph)
199 (if (not (null? graph))
200 (let* ((byte-cell (find-min-neighbours graph))
201 (neighbours (byte-cell-interferes-with byte-cell)))
202 (let ((new-graph (remove byte-cell graph)))
203 (delete byte-cell neighbours)
204 (alloc-reg new-graph)
205 (undelete byte-cell neighbours))
206 (if (not (byte-cell-adr byte-cell))
207 (color byte-cell)))))
209 (pp register-allocation:)
210 (time (alloc-reg (set->list all-live))) ;; TODO convert find-min-neighbors and alloc-reg to use tables, not urgent since it's not a bottleneck
211 (display (string-append (number->string (+ max-adr 1)) " RAM bytes\n"))))