1 ! Copyright (C) 2009, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs compiler.cfg compiler.cfg.comparisons
4 compiler.cfg.instructions compiler.cfg.predecessors
5 compiler.cfg.registers compiler.cfg.rpo compiler.cfg.utilities
6 cpu.architecture grouping kernel layouts locals make math
8 IN: compiler.cfg.gc-checks
12 : insert-gc-check? ( bb -- ? )
14 [ drop f ] [ instructions>> [ allocation-insn? ] any? ] if ;
16 : blocks-with-gc ( cfg -- bbs )
17 post-order [ insert-gc-check? ] filter ;
19 GENERIC# gc-check-offsets* 1 ( call-index seen-allocation? insn n -- call-index seen-allocation? )
21 :: gc-check-here ( call-index seen-allocation? insn insn-index -- call-index seen-allocation? )
22 seen-allocation? [ call-index , ] when
25 M: ##callback-inputs gc-check-offsets* gc-check-here ;
26 M: ##phi gc-check-offsets* gc-check-here ;
27 M: gc-map-insn gc-check-offsets* gc-check-here ;
28 M: allocation-insn gc-check-offsets* 3drop t ;
29 M: insn gc-check-offsets* 2drop ;
31 : gc-check-offsets ( insns -- seq )
34 [ gc-check-offsets* ] each-index
38 :: split-instructions ( insns seq -- insns-seq )
39 ! Divide a basic block into sections, where every section
40 ! other than the first requires a GC check.
42 insns 0 seq [| insns from to |
43 from to insns subseq ,
49 GENERIC: allocation-size* ( insn -- n )
51 M: ##allot allocation-size* size>> ;
52 M: ##box-alien allocation-size* drop 5 cells ;
53 M: ##box-displaced-alien allocation-size* drop 5 cells ;
55 : allocation-size ( insns -- n )
56 [ allocation-insn? ] filter
57 [ allocation-size* data-alignment get align ] map-sum ;
59 : add-gc-checks ( insns-seq -- )
61 first2 allocation-size
62 cc<= int-rep next-vreg-rep int-rep next-vreg-rep
63 ##check-nursery-branch new-insn
67 : make-blocks ( insns-seq -- bbs )
68 [ f insns>block ] map ;
72 [ <gc-map> ##call-gc, ##branch, ] V{ } make
75 :: connect-gc-checks ( bbs -- )
76 ! Every basic block but the last has two successors:
77 ! the next block, and a GC call.
78 ! Every basic block but the first has two predecessors:
79 ! the previous block, and the previous block's GC call.
81 len [ <gc-call> ] replicate :> gc-calls
84 n 1 + bbs nth :> next-bb
85 n gc-calls nth :> gc-call
86 V{ next-bb gc-call } bb successors<<
87 V{ next-bb } gc-call successors<<
88 V{ bb } gc-call predecessors<<
89 V{ bb gc-call } next-bb predecessors<<
92 :: update-predecessor-phis ( from to bb -- )
96 [ dup from eq? [ drop bb ] when ] dip
101 :: (insert-gc-checks) ( bb bbs -- )
102 bb predecessors>> bbs first predecessors<<
103 bb successors>> bbs last successors<<
104 bb predecessors>> [ bb bbs first update-successors ] each
107 [ update-predecessors ]
108 [ update-predecessor-phis ] 3bi
111 : process-block ( bb -- )
112 dup instructions>> dup gc-check-offsets split-instructions
113 [ add-gc-checks ] [ make-blocks dup connect-gc-checks ] bi
118 : insert-gc-checks ( cfg -- )
119 [ needs-predecessors ]
120 [ blocks-with-gc [ process-block ] each ]
121 [ cfg-changed ] tri ;