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 : wipe-locs ( uninitialized-locs -- )
  54     '[
  55         int-rep next-vreg-rep
  56         [ 0 ##load-tagged ]
  57         [ '[ [ _ ] dip ##replace ] each ] bi
  58     ] unless-empty ;
  59
  60 : <gc-call> ( uninitialized-locs gc-roots -- bb )
  61     [ <basic-block> ] 2dip
  62     [ [ wipe-locs ] [ ##call-gc ] bi* ##branch ] V{ } make
  63     >>instructions t >>unlikely? ;
  64
  65 :: insert-guard ( body check bb -- )
  66     bb predecessors>> check predecessors<<
  67     V{ bb body }      check successors<<
  68
  69     V{ check }        body predecessors<<
  70     V{ bb }           body successors<<
  71
  72     V{ check body }   bb predecessors<<
  73
  74     check predecessors>> [ bb check update-successors ] each ;
  75
  76 : (insert-gc-check) ( uninitialized-locs gc-roots phis size bb -- )
  77     [ [ <gc-call> ] 2dip <gc-check> ] dip insert-guard ;
  78
  79 GENERIC: allocation-size* ( insn -- n )
  80
  81 M: ##allot allocation-size* size>> ;
  82
  83 M: ##box-alien allocation-size* drop 5 cells ;
  84
  85 M: ##box-displaced-alien allocation-size* drop 5 cells ;
  86
  87 : allocation-size ( bb -- n )
  88     instructions>>
  89     [ ##allocation? ] filter
  90     [ allocation-size* data-alignment get align ] map-sum ;
  91
  92 : gc-live-in ( bb -- vregs )
  93     [ live-in keys ] [ instructions>> [ ##phi? ] filter [ dst>> ] map ] bi
  94     append ;
  95
  96 : live-tagged ( bb -- vregs )
  97     gc-live-in [ rep-of tagged-rep? ] filter ;
  98
  99 : remove-phis ( bb -- phis )
 100     [ [ ##phi? ] partition ] change-instructions drop ;
 101
 102 : insert-gc-check ( bb -- )
 103     {
 104         [ uninitialized-locs ]
 105         [ live-tagged ]
 106         [ remove-phis ]
 107         [ allocation-size ]
 108         [ ]
 109     } cleave
 110     (insert-gc-check) ;
 111
 112 PRIVATE>
 113
 114 : insert-gc-checks ( cfg -- cfg' )
 115     dup blocks-with-gc [
 116         [
 117             needs-predecessors
 118             dup compute-ssa-live-sets
 119             dup compute-uninitialized-sets
 120         ] dip
 121         [ insert-gc-check ] each
 122         cfg-changed
 123     ] unless-empty ;