basis/compiler/cfg/utilities/utilities.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators combinators.short-circuit
   4 compiler.cfg compiler.cfg.instructions cpu.architecture kernel
   5 layouts locals make math namespaces sequences sets vectors fry ;
   6 IN: compiler.cfg.utilities
   7
   8 : value-info-small-fixnum? ( value-info -- ? )
   9     literal>> {
  10         { [ dup fixnum? ] [ tag-fixnum small-enough? ] }
  11         [ drop f ]
  12     } cond ;
  13
  14 : value-info-small-tagged? ( value-info -- ? )
  15     dup literal?>> [
  16         literal>> {
  17             { [ dup fixnum? ] [ tag-fixnum small-enough? ] }
  18             { [ dup not ] [ drop t ] }
  19             [ drop f ]
  20         } cond
  21     ] [ drop f ] if ;
  22
  23 : set-basic-block ( basic-block -- )
  24     [ basic-block set ] [ instructions>> building set ] bi ;
  25
  26 : begin-basic-block ( -- )
  27     <basic-block> basic-block get [
  28         dupd successors>> push
  29     ] when*
  30     set-basic-block ;
  31
  32 : end-basic-block ( -- )
  33     building off
  34     basic-block off ;
  35
  36 : emit-primitive ( node -- )
  37     word>> ##call ##branch begin-basic-block ;
  38
  39 : with-branch ( quot -- final-bb )
  40     [
  41         begin-basic-block
  42         call
  43         basic-block get dup [ ##branch ] when
  44     ] with-scope ; inline
  45
  46 : emit-conditional ( branches -- )
  47     end-basic-block
  48     begin-basic-block
  49     basic-block get '[ [ _ swap successors>> push ] when* ] each ;
  50
  51 : back-edge? ( from to -- ? )
  52     [ number>> ] bi@ >= ;
  53
  54 : empty-block? ( bb -- ? )
  55     instructions>> {
  56         [ length 1 = ]
  57         [ first ##branch? ]
  58     } 1&& ;
  59
  60 SYMBOL: visited
  61
  62 : (skip-empty-blocks) ( bb -- bb' )
  63     dup visited get key? [
  64         dup empty-block? [
  65             dup visited get conjoin
  66             successors>> first (skip-empty-blocks)
  67         ] when
  68     ] unless ;
  69
  70 : skip-empty-blocks ( bb -- bb' )
  71     H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
  72
  73 ! assoc mapping predecessors to sequences
  74 SYMBOL: added-instructions
  75
  76 : add-instructions ( predecessor quot -- )
  77     [
  78         added-instructions get
  79         [ drop V{ } clone ] cache
  80         building
  81     ] dip with-variable ; inline
  82
  83 :: insert-basic-block ( from to bb -- )
  84     bb from 1vector >>predecessors drop
  85     bb to 1vector >>successors drop
  86     to predecessors>> [ dup from eq? [ drop bb ] when ] change-each
  87     from successors>> [ dup to eq? [ drop bb ] when ] change-each ;
  88
  89 : <simple-block> ( insns -- bb )
  90     <basic-block>
  91     swap >vector
  92     \ ##branch new-insn over push
  93     >>instructions ;
  94
  95 : insert-basic-blocks ( bb -- )
  96     [ added-instructions get ] dip
  97     '[ [ _ ] dip <simple-block> insert-basic-block ] assoc-each ;