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 combinators fry kernel layouts locals
   4 math make namespaces sequences cpu.architecture
   5 compiler.cfg
   6 compiler.cfg.rpo
   7 compiler.cfg.hats
   8 compiler.cfg.registers
   9 compiler.cfg.utilities
  10 compiler.cfg.comparisons
  11 compiler.cfg.instructions
  12 compiler.cfg.predecessors
  13 compiler.cfg.liveness
  14 compiler.cfg.liveness.ssa
  15 compiler.cfg.stacks.uninitialized ;
  16 IN: compiler.cfg.gc-checks
  17
  18 <PRIVATE
  19
  20 ! Garbage collection check insertion. This pass runs after
  21 ! representation selection, since it needs to know which vregs
  22 ! can contain tagged pointers.
  23
  24 : insert-gc-check? ( bb -- ? )
  25     dup kill-block?>>
  26     [ drop f ] [ instructions>> [ ##allocation? ] any? ] if ;
  27
  28 : blocks-with-gc ( cfg -- bbs )
  29     post-order [ insert-gc-check? ] filter ;
  30
  31 ! A GC check for bb consists of two new basic blocks, gc-check
  32 ! and gc-call:
  33 !
  34 !    gc-check
  35 !   /      \
  36 !  |     gc-call
  37 !   \      /
  38 !      bb
  39
  40 ! Any ##phi instructions at the start of bb are transplanted
  41 ! into the gc-check block.
  42
  43 : <gc-check> ( phis size -- bb )
  44     [ <basic-block> ] 2dip
  45     [
  46         [ % ]
  47         [
  48             cc<= int-rep next-vreg-rep int-rep next-vreg-rep
  49             ##check-nursery-branch
  50         ] bi*
  51     ] V{ } make >>instructions ;
  52
  53 : scrubbed ( uninitialized-locs -- scrub-d scrub-r )
  54     [ ds-loc? ] partition [ [ n>> ] map ] bi@ ;
  55
  56 : <gc-call> ( uninitialized-locs gc-roots -- bb )
  57     [ <basic-block> ] 2dip
  58     [ [ scrubbed ] dip ##gc-map ##call-gc ##branch ] V{ } make
  59     >>instructions t >>unlikely? ;
  60
  61 :: insert-guard ( body check bb -- )
  62     bb predecessors>> check predecessors<<
  63     V{ bb body }      check successors<<
  64
  65     V{ check }        body predecessors<<
  66     V{ bb }           body successors<<
  67
  68     V{ check body }   bb predecessors<<
  69
  70     check predecessors>> [ bb check update-successors ] each ;
  71
  72 : (insert-gc-check) ( uninitialized-locs gc-roots phis size bb -- )
  73     [ [ <gc-call> ] 2dip <gc-check> ] dip insert-guard ;
  74
  75 GENERIC: allocation-size* ( insn -- n )
  76
  77 M: ##allot allocation-size* size>> ;
  78
  79 M: ##box-alien allocation-size* drop 5 cells ;
  80
  81 M: ##box-displaced-alien allocation-size* drop 5 cells ;
  82
  83 : allocation-size ( bb -- n )
  84     instructions>>
  85     [ ##allocation? ] filter
  86     [ allocation-size* data-alignment get align ] map-sum ;
  87
  88 : gc-live-in ( bb -- vregs )
  89     [ live-in keys ] [ instructions>> [ ##phi? ] filter [ dst>> ] map ] bi
  90     append ;
  91
  92 : live-tagged ( bb -- vregs )
  93     gc-live-in [ rep-of tagged-rep? ] filter ;
  94
  95 : remove-phis ( bb -- phis )
  96     [ [ ##phi? ] partition ] change-instructions drop ;
  97
  98 : insert-gc-check ( bb -- )
  99     {
 100         [ uninitialized-locs ]
 101         [ live-tagged ]
 102         [ remove-phis ]
 103         [ allocation-size ]
 104         [ ]
 105     } cleave
 106     (insert-gc-check) ;
 107
 108 PRIVATE>
 109
 110 : insert-gc-checks ( cfg -- cfg' )
 111     dup blocks-with-gc [
 112         [
 113             needs-predecessors
 114             dup compute-ssa-live-sets
 115             dup compute-uninitialized-sets
 116         ] dip
 117         [ insert-gc-check ] each
 118         cfg-changed
 119     ] unless-empty ;