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.rpo
   7 compiler.cfg.comparisons
   8 compiler.cfg.stack-frame
   9 compiler.cfg.instructions
  10 compiler.cfg.utilities ;
  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     [ 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 RPO, then we
  25     #! don't need to branch.
  26     [ number>> ] bi@ 1 - = ; inline
  27
  28 : emit-loop-entry? ( bb -- ? )
  29     dup predecessors>> [ swap back-edge? ] with any? ;
  30
  31 : emit-branch ( bb successor -- )
  32     dup emit-loop-entry? [ _loop-entry ] when
  33     2dup useless-branch? [ 2drop ] [ nip number>> _branch ] if ;
  34
  35 M: ##branch linearize-insn
  36     drop dup successors>> first emit-branch ;
  37
  38 : successors ( bb -- first second ) successors>> first2 ; inline
  39
  40 : (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc )
  41     [ dup successors ]
  42     [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
  43
  44 : binary-conditional ( bb insn -- bb successor label2 src1 src2 cc )
  45     [ (binary-conditional) ]
  46     [ drop dup successors>> second useless-branch? ] 2bi
  47     [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
  48
  49 : with-regs ( insn quot -- )
  50     over regs>> [ call ] dip building get last (>>regs) ; inline
  51
  52 M: ##compare-branch linearize-insn
  53     [ binary-conditional _compare-branch ] with-regs emit-branch ;
  54
  55 M: ##compare-imm-branch linearize-insn
  56     [ binary-conditional _compare-imm-branch ] with-regs emit-branch ;
  57
  58 M: ##compare-float-branch linearize-insn
  59     [ binary-conditional _compare-float-branch ] with-regs emit-branch ;
  60
  61 : overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
  62     [ dup successors number>> ]
  63     [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
  64
  65 M: ##fixnum-add linearize-insn
  66     [ overflow-conditional _fixnum-add ] with-regs emit-branch ;
  67
  68 M: ##fixnum-sub linearize-insn
  69     [ overflow-conditional _fixnum-sub ] with-regs emit-branch ;
  70
  71 M: ##fixnum-mul linearize-insn
  72     [ overflow-conditional _fixnum-mul ] with-regs emit-branch ;
  73
  74 M: ##dispatch linearize-insn
  75     swap
  76     [ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]
  77     [ successors>> [ number>> _dispatch-label ] each ]
  78     bi* ;
  79
  80 : (compute-gc-roots) ( n live-values -- n )
  81     [
  82         [ nip 2array , ]
  83         [ drop reg-class>> reg-size + ]
  84         3bi
  85     ] assoc-each ;
  86
  87 : oop-values ( regs -- regs' )
  88     [ drop reg-class>> int-regs eq? ] assoc-filter ;
  89
  90 : data-values ( regs -- regs' )
  91     [ drop reg-class>> double-float-regs eq? ] assoc-filter ;
  92
  93 : compute-gc-roots ( live-values -- alist )
  94     [
  95         [ 0 ] dip
  96         ! we put float registers last; the GC doesn't actually scan them
  97         [ oop-values (compute-gc-roots) ]
  98         [ data-values (compute-gc-roots) ] bi
  99         drop
 100     ] { } make ;
 101
 102 : count-gc-roots ( live-values -- n )
 103     ! Size of GC root area, minus the float registers
 104     oop-values assoc-size ;
 105
 106 M: ##gc linearize-insn
 107     nip
 108     [
 109         [ temp1>> ]
 110         [ temp2>> ]
 111         [
 112             live-values>>
 113             [ compute-gc-roots ]
 114             [ count-gc-roots ]
 115             [ gc-roots-size ]
 116             tri
 117         ] tri
 118         _gc
 119     ] with-regs ;
 120
 121 : linearize-basic-blocks ( cfg -- insns )
 122     [
 123         [ [ linearize-basic-block ] each-basic-block ]
 124         [ spill-counts>> _spill-counts ]
 125         bi
 126     ] { } make ;
 127
 128 : flatten-cfg ( cfg -- mr )
 129     [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
 130     <mr> ;