unfinished/compiler/machine/builder/builder.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 compiler.cfg compiler.instructions compiler.machine ;
   5 IN: compiler.machine.builder
   6
   7 ! Convert CFG IR to machine IR.
   8
   9 SYMBOL: block-counter
  10
  11 : number-basic-block ( basic-block -- )
  12     #! Make this fancy later.
  13     dup number>> [ drop ] [
  14         <label> >>label
  15         block-counter [ dup 1+ ] change >>number
  16         [ , ] [
  17             successors>> <reversed>
  18             [ number-basic-block ] each
  19         ] bi
  20     ] if ;
  21
  22 : flatten-basic-blocks ( procedure -- blocks )
  23     [
  24         0 block-counter
  25         [ number-basic-block ]
  26         with-variable
  27     ] { } make ;
  28
  29 GENERIC: linearize* ( basic-block insn -- )
  30
  31 M: object linearize* , drop ;
  32
  33 M: %branch linearize*
  34     drop successors>> first label>> _branch ;
  35
  36 : conditional ( basic-block -- label1 label2 )
  37     successors>> first2 [ label>> ] bi@ swap ; inline
  38
  39 : boolean-conditional ( basic-block insn -- label1 vreg label2 )
  40     [ conditional ] [ vreg>> ] bi* swap ; inline
  41
  42 M: %branch-f linearize*
  43     boolean-conditional _branch-f _branch ;
  44
  45 M: %branch-t linearize*
  46     boolean-conditional _branch-t _branch ;
  47
  48 M: %if-intrinsic linearize*
  49     [ conditional ] [ [ quot>> ] [ vregs>> ] bi ] bi*
  50     _if-intrinsic _branch ;
  51
  52 M: %boolean-intrinsic linearize*
  53     [
  54         "false" define-label
  55         "end" define-label
  56         "false" get over [ quot>> ] [ vregs>> ] bi _if-intrinsic
  57         t over out>> %load-literal
  58         "end" get _branch
  59         "false" resolve-label
  60         f over out>> %load-literal
  61         "end" resolve-label
  62     ] with-scope
  63     2drop ;
  64
  65 : build-machine ( procedure -- insns )
  66     [
  67         entry>> flatten-basic-blocks [
  68             [ label>> _label ]
  69             [ dup instructions>> [ linearize* ] with each ]
  70             bi
  71         ] each
  72     ] { } make ;