basis/compiler/cfg/useless-blocks/useless-blocks.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel accessors sequences combinators classes vectors
   4 compiler.cfg compiler.cfg.rpo compiler.cfg.instructions ;
   5 IN: compiler.cfg.useless-blocks
   6
   7 : update-predecessor-for-delete ( bb -- )
   8     dup predecessors>> first [
   9         [
  10             2dup eq? [ drop successors>> first ] [ nip ] if
  11         ] with map
  12     ] change-successors drop ;
  13
  14 : update-successor-for-delete ( bb -- )
  15     [ predecessors>> first ]
  16     [ successors>> first predecessors>> ]
  17     bi set-first ;
  18
  19 : delete-basic-block ( bb -- )
  20     [ update-predecessor-for-delete ]
  21     [ update-successor-for-delete ]
  22     bi ;
  23
  24 : delete-basic-block? ( bb -- ? )
  25     {
  26         { [ dup instructions>> length 1 = not ] [ f ] }
  27         { [ dup predecessors>> length 1 = not ] [ f ] }
  28         { [ dup successors>> length 1 = not ] [ f ] }
  29         { [ dup instructions>> first ##branch? not ] [ f ] }
  30         [ t ]
  31     } cond nip ;
  32
  33 : delete-useless-blocks ( cfg -- cfg' )
  34     dup [
  35         dup delete-basic-block? [ delete-basic-block ] [ drop ] if
  36     ] each-basic-block ;
  37
  38 : delete-conditional? ( bb -- ? )
  39     dup instructions>> [ drop f ] [
  40         last class {
  41             ##compare-branch
  42             ##compare-imm-branch
  43             ##compare-float-branch
  44         } memq? [ successors>> first2 eq? ] [ drop f ] if
  45     ] if-empty ;
  46
  47 : delete-conditional ( bb -- )
  48     dup successors>> first 1vector >>successors
  49     [ but-last f \ ##branch boa suffix ] change-instructions
  50     drop ;
  51
  52 : delete-useless-conditionals ( cfg -- cfg' )
  53     dup [
  54         dup delete-conditional? [ delete-conditional ] [ drop ] if
  55     ] each-basic-block ;