basis/compiler/cfg/linearization/linearization.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel math accessors sequences namespaces make
   4 combinators classes
   5 compiler.cfg
   6 compiler.cfg.rpo
   7 compiler.cfg.instructions ;
   8 IN: compiler.cfg.linearization
   9
  10 ! Convert CFG IR to machine IR.
  11 GENERIC: linearize-insn ( basic-block insn -- )
  12
  13 : linearize-insns ( basic-block -- )
  14     dup instructions>> [ linearize-insn ] with each ; inline
  15
  16 M: insn linearize-insn , drop ;
  17
  18 : useless-branch? ( basic-block successor -- ? )
  19     #! If our successor immediately follows us in RPO, then we
  20     #! don't need to branch.
  21     [ number>> ] bi@ 1- = ; inline
  22
  23 : branch-to-branch? ( successor -- ? )
  24     #! A branch to a block containing just a jump return is cloned.
  25     instructions>> dup length 2 = [
  26         [ first ##epilogue? ]
  27         [ second [ ##return? ] [ ##jump? ] bi or ] bi and
  28     ] [ drop f ] if ;
  29
  30 : emit-branch ( basic-block successor -- )
  31     {
  32         { [ 2dup useless-branch? ] [ 2drop ] }
  33         { [ dup branch-to-branch? ] [ nip linearize-insns ] }
  34         [ nip number>> _branch ]
  35     } cond ;
  36
  37 M: ##branch linearize-insn
  38     drop dup successors>> first emit-branch ;
  39
  40 : (binary-conditional) ( basic-block insn -- basic-block successor1 successor2 src1 src2 cc )
  41     [ dup successors>> first2 ]
  42     [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
  43
  44 : binary-conditional ( basic-block insn -- basic-block 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 M: ##compare-branch linearize-insn
  50     binary-conditional _compare-branch emit-branch ;
  51
  52 M: ##compare-imm-branch linearize-insn
  53     binary-conditional _compare-imm-branch emit-branch ;
  54
  55 M: ##compare-float-branch linearize-insn
  56     binary-conditional _compare-float-branch emit-branch ;
  57
  58 : gc? ( bb -- ? )
  59     instructions>> [
  60         class {
  61             ##allot
  62             ##integer>bignum
  63             ##box-float
  64             ##box-alien
  65         } memq?
  66     ] contains? ;
  67
  68 : linearize-basic-block ( bb -- )
  69     [ number>> _label ]
  70     [ gc? [ _gc ] when ]
  71     [ linearize-insns ]
  72     tri ;
  73
  74 : linearize-basic-blocks ( rpo -- insns )
  75     [ [ linearize-basic-block ] each ] { } make ;
  76
  77 : build-mr ( cfg -- mr )
  78     [ entry>> reverse-post-order linearize-basic-blocks ]
  79     [ word>> ] [ label>> ]
  80     tri <mr> ;