basis/compiler/cfg/tco/tco.factor

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