basis/compiler/cfg/linearization/linearization.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel math accessors sequences namespaces make
   4 combinators assocs arrays locals cpu.architecture
   5 compiler.cfg
   6 compiler.cfg.comparisons
   7 compiler.cfg.stack-frame
   8 compiler.cfg.instructions
   9 compiler.cfg.utilities
  10 compiler.cfg.linearization.order ;
  11 IN: compiler.cfg.linearization
  12
  13 ! Convert CFG IR to machine IR.
  14 GENERIC: linearize-insn ( basic-block insn -- )
  15
  16 : linearize-basic-block ( bb -- )
  17     [ block-number _label ]
  18     [ dup instructions>> [ linearize-insn ] with each ]
  19     bi ;
  20
  21 M: insn linearize-insn , drop ;
  22
  23 : useless-branch? ( basic-block successor -- ? )
  24     ! If our successor immediately follows us in linearization
  25     ! order then we don't need to branch.
  26     [ block-number ] bi@ 1 - = ; inline
  27
  28 : emit-branch ( bb successor -- )
  29     2dup useless-branch? [ 2drop ] [ nip block-number _branch ] if ;
  30
  31 M: ##branch linearize-insn
  32     drop dup successors>> first emit-branch ;
  33
  34 : successors ( bb -- first second ) successors>> first2 ; inline
  35
  36 : (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc )
  37     [ dup successors ]
  38     [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
  39
  40 : binary-conditional ( bb insn -- bb successor label2 src1 src2 cc )
  41     [ (binary-conditional) ]
  42     [ drop dup successors>> second useless-branch? ] 2bi
  43     [ [ swap block-number ] 3dip ] [ [ block-number ] 3dip negate-cc ] if ;
  44
  45 M: ##compare-branch linearize-insn
  46     binary-conditional _compare-branch emit-branch ;
  47
  48 M: ##compare-imm-branch linearize-insn
  49     binary-conditional _compare-imm-branch emit-branch ;
  50
  51 M: ##compare-float-branch linearize-insn
  52     binary-conditional _compare-float-branch emit-branch ;
  53
  54 : overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
  55     [ dup successors block-number ]
  56     [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
  57
  58 M: ##fixnum-add linearize-insn
  59     overflow-conditional _fixnum-add emit-branch ;
  60
  61 M: ##fixnum-sub linearize-insn
  62     overflow-conditional _fixnum-sub emit-branch ;
  63
  64 M: ##fixnum-mul linearize-insn
  65     overflow-conditional _fixnum-mul emit-branch ;
  66
  67 M: ##dispatch linearize-insn
  68     swap
  69     [ [ src>> ] [ temp>> ] bi _dispatch ]
  70     [ successors>> [ block-number _dispatch-label ] each ]
  71     bi* ;
  72
  73 : (compute-gc-roots) ( n live-values -- n )
  74     [
  75         [ nip 2array , ]
  76         [ drop reg-class>> reg-size + ]
  77         3bi
  78     ] assoc-each ;
  79
  80 : oop-values ( regs -- regs' )
  81     [ drop reg-class>> int-regs eq? ] assoc-filter ;
  82
  83 : data-values ( regs -- regs' )
  84     [ drop reg-class>> double-float-regs eq? ] assoc-filter ;
  85
  86 : compute-gc-roots ( live-values -- alist )
  87     [
  88         [ 0 ] dip
  89         ! we put float registers last; the GC doesn't actually scan them
  90         [ oop-values (compute-gc-roots) ]
  91         [ data-values (compute-gc-roots) ] bi
  92         drop
  93     ] { } make ;
  94
  95 : count-gc-roots ( live-values -- n )
  96     ! Size of GC root area, minus the float registers
  97     oop-values assoc-size ;
  98
  99 M: ##gc linearize-insn
 100     nip
 101     [ temp1>> ]
 102     [ temp2>> ]
 103     [
 104         live-values>>
 105         [ compute-gc-roots ]
 106         [ count-gc-roots ]
 107         [ gc-roots-size ]
 108         tri
 109     ] tri
 110     _gc ;
 111
 112 : linearize-basic-blocks ( cfg -- insns )
 113     [
 114         [ linearization-order [ linearize-basic-block ] each ]
 115         [ spill-counts>> _spill-counts ]
 116         bi
 117     ] { } make ;
 118
 119 : flatten-cfg ( cfg -- mr )
 120     [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
 121     <mr> ;