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

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