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