basis/compiler/cfg/gc-checks/gc-checks.factor

   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
   7 namespaces sequences ;
   8 IN: compiler.cfg.gc-checks
   9
  10 <PRIVATE
  11
  12 : insert-gc-check? ( bb -- ? )
  13     dup kill-block?>>
  14     [ drop f ] [ instructions>> [ allocation-insn? ] any? ] if ;
  15
  16 : blocks-with-gc ( cfg -- bbs )
  17     post-order [ insert-gc-check? ] filter ;
  18
  19 GENERIC#: gc-check-offsets* 1 ( call-index seen-allocation? insn n -- call-index seen-allocation? )
  20
  21 :: gc-check-here ( call-index seen-allocation? insn insn-index -- call-index seen-allocation? )
  22     seen-allocation? [ call-index , ] when
  23     insn-index 1 + f ;
  24
  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 ;
  30
  31 : gc-check-offsets ( insns -- seq )
  32     [
  33         [ 0 f ] dip
  34         [ gc-check-offsets* ] each-index
  35         [ , ] [ drop ] if
  36     ] { } make ;
  37
  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.
  41     [
  42         insns 0 seq [| insns from to |
  43             from to insns subseq ,
  44             insns to
  45         ] each
  46         tail ,
  47     ] { } make ;
  48
  49 GENERIC: allocation-size* ( insn -- n )
  50
  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 ;
  54
  55 : allocation-size ( insns -- n )
  56     [ allocation-insn? ] filter
  57     [ allocation-size* data-alignment get align ] map-sum ;
  58
  59 : add-gc-checks ( insns-seq -- )
  60     2 <clumps> [
  61         first2 allocation-size
  62         cc<= int-rep next-vreg-rep int-rep next-vreg-rep
  63         ##check-nursery-branch new-insn
  64         swap push
  65     ] each ;
  66
  67 : make-blocks ( insns-seq -- bbs )
  68     [ f insns>block ] map ;
  69
  70 : <gc-call> ( -- bb )
  71     <basic-block>
  72     [ <gc-map> ##call-gc, ##branch, ] V{ } make
  73     >>instructions ;
  74
  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.
  80     bbs length 1 - :> len
  81     len [ <gc-call> ] replicate :> gc-calls
  82     len [| n |
  83         n bbs nth :> bb
  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<<
  90     ] each-integer ;
  91
  92 :: update-predecessor-phis ( from to bb -- )
  93     to [
  94         [
  95             [
  96                 [ dup from eq? [ drop bb ] when ] dip
  97             ] assoc-map
  98         ] change-inputs drop
  99     ] each-phi ;
 100
 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
 105     bb successors>> [
 106         [ bb ] dip bbs last
 107         [ update-predecessors ]
 108         [ update-predecessor-phis ] 3bi
 109     ] each ;
 110
 111 : process-block ( bb -- )
 112     dup instructions>> dup gc-check-offsets split-instructions
 113     [ add-gc-checks ] [ make-blocks dup connect-gc-checks ] bi
 114     (insert-gc-checks) ;
 115
 116 PRIVATE>
 117
 118 : insert-gc-checks ( cfg -- )
 119     [ needs-predecessors ]
 120     [ blocks-with-gc [ process-block ] each ]
 121     [ cfg-changed ] tri ;