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     instructions>> [ ##allocation? ] any? ;
  26
  27 : blocks-with-gc ( cfg -- bbs )
  28     post-order [ insert-gc-check? ] filter ;
  29
  30 ! A GC check for bb consists of two new basic blocks, gc-check
  31 ! and gc-call:
  32 !
  33 !    gc-check
  34 !   /      \
  35 !  |     gc-call
  36 !   \      /
  37 !      bb
  38
  39 ! Any ##phi instructions at the start of bb are transplanted
  40 ! into the gc-check block.
  41
  42 : <gc-check> ( phis size -- bb )
  43     [ <basic-block> ] 2dip
  44     [
  45         [ % ]
  46         [
  47             cc<= int-rep next-vreg-rep int-rep next-vreg-rep
  48             ##check-nursery-branch
  49         ] bi*
  50     ] V{ } make >>instructions ;
  51
  52 : wipe-locs ( uninitialized-locs -- )
  53     '[
  54         int-rep next-vreg-rep
  55         [ 0 ##load-tagged ]
  56         [ '[ [ _ ] dip ##replace ] each ] bi
  57     ] unless-empty ;
  58
  59 : <gc-call> ( uninitialized-locs gc-roots -- bb )
  60     [ <basic-block> ] 2dip
  61     [ [ wipe-locs ] [ ##call-gc ] bi* ##branch ] V{ } make
  62     >>instructions t >>unlikely? ;
  63
  64 :: insert-guard ( body check bb -- )
  65     bb predecessors>> check predecessors<<
  66     V{ bb body }      check successors<<
  67
  68     V{ check }        body predecessors<<
  69     V{ bb }           body successors<<
  70
  71     V{ check body }   bb predecessors<<
  72
  73     check predecessors>> [ bb check update-successors ] each ;
  74
  75 : (insert-gc-check) ( uninitialized-locs gc-roots phis size bb -- )
  76     [ [ <gc-call> ] 2dip <gc-check> ] dip insert-guard ;
  77
  78 GENERIC: allocation-size* ( insn -- n )
  79
  80 M: ##allot allocation-size* size>> ;
  81
  82 M: ##box-alien allocation-size* drop 5 cells ;
  83
  84 M: ##box-displaced-alien allocation-size* drop 5 cells ;
  85
  86 : allocation-size ( bb -- n )
  87     instructions>>
  88     [ ##allocation? ] filter
  89     [ allocation-size* data-alignment get align ] map-sum ;
  90
  91 : gc-live-in ( bb -- vregs )
  92     [ live-in keys ] [ instructions>> [ ##phi? ] filter [ dst>> ] map ] bi
  93     append ;
  94
  95 : live-tagged ( bb -- vregs )
  96     gc-live-in [ rep-of tagged-rep? ] filter ;
  97
  98 : remove-phis ( bb -- phis )
  99     [ [ ##phi? ] partition ] change-instructions drop ;
 100
 101 : insert-gc-check ( bb -- )
 102     {
 103         [ uninitialized-locs ]
 104         [ live-tagged ]
 105         [ remove-phis ]
 106         [ allocation-size ]
 107         [ ]
 108     } cleave
 109     (insert-gc-check) ;
 110
 111 PRIVATE>
 112
 113 : insert-gc-checks ( cfg -- cfg' )
 114     dup blocks-with-gc [
 115         [
 116             needs-predecessors
 117             dup compute-ssa-live-sets
 118             dup compute-uninitialized-sets
 119         ] dip
 120         [ insert-gc-check ] each
 121         cfg-changed
 122     ] unless-empty ;