basis/compiler/cfg/tco/tco.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators.short-circuit kernel math
   4 namespaces sequences fry combinators
   5 compiler.utilities
   6 compiler.cfg
   7 compiler.cfg.rpo
   8 compiler.cfg.hats
   9 compiler.cfg.instructions
  10 compiler.cfg.utilities ;
  11 IN: compiler.cfg.tco
  12
  13 ! Tail call optimization.
  14
  15 : return? ( bb -- ? )
  16     skip-empty-blocks
  17     instructions>> {
  18         [ length 2 = ]
  19         [ first ##epilogue? ]
  20         [ second ##return? ]
  21     } 1&& ;
  22
  23 : tail-call? ( bb -- ? )
  24     {
  25         [ instructions>> { [ length 2 >= ] [ last ##branch? ] } 1&& ]
  26         [ successors>> first return? ]
  27     } 1&& ;
  28
  29 : word-tail-call? ( bb -- ? )
  30     instructions>> penultimate ##call? ;
  31
  32 : convert-tail-call ( ..a bb quot: ( ..a insn -- ..a tail-insn ) -- ..b )
  33     '[
  34         instructions>>
  35         [ pop* ] [ pop ] [ ] tri
  36         [ [ \ ##epilogue new-insn ] dip push ]
  37         [ _ dip push ] bi
  38     ]
  39     [ successors>> delete-all ]
  40     bi ; inline
  41
  42 : convert-word-tail-call ( bb -- )
  43     [ word>> \ ##jump new-insn ] convert-tail-call ;
  44
  45 : loop-tail-call? ( bb -- ? )
  46     instructions>> penultimate
  47     { [ ##call? ] [ word>> cfg get label>> eq? ] } 1&& ;
  48
  49 : convert-loop-tail-call ( bb -- )
  50     ! If a word calls itself, this becomes a loop in the CFG.
  51     [ instructions>> [ pop* ] [ pop* ] [ [ \ ##branch new-insn ] dip push ] tri ]
  52     [ successors>> delete-all ]
  53     [ [ cfg get entry>> successors>> first ] dip successors>> push ]
  54     tri ;
  55
  56 : optimize-tail-call ( bb -- )
  57     dup tail-call? [
  58         {
  59             { [ dup loop-tail-call? ] [ convert-loop-tail-call ] }
  60             { [ dup word-tail-call? ] [ convert-word-tail-call ] }
  61             [ drop ]
  62         } cond
  63     ] [ drop ] if ;
  64
  65 : optimize-tail-calls ( cfg -- cfg' )
  66     dup [ optimize-tail-call ] each-basic-block
  67
  68     cfg-changed predecessors-changed ;