basis/compiler/tree/finalization/finalization.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel accessors sequences words memoize combinators
   4 classes classes.builtin classes.tuple classes.singleton
   5 math.partial-dispatch fry assocs combinators.short-circuit
   6 compiler.tree
   7 compiler.tree.combinators
   8 compiler.tree.propagation.info
   9 compiler.tree.late-optimizations ;
  10 IN: compiler.tree.finalization
  11
  12 ! This is a late-stage optimization.
  13 ! See the comment in compiler.tree.late-optimizations.
  14
  15 ! This pass runs after propagation, so that it can expand
  16 ! type predicates; these cannot be expanded before
  17 ! propagation since we need to see 'fixnum?' instead of
  18 ! 'tag 0 eq?' and so on, for semantic reasoning.
  19
  20 ! We also delete empty stack shuffles and copies to facilitate
  21 ! tail call optimization in the code generator.
  22
  23 GENERIC: finalize* ( node -- nodes )
  24
  25 : finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;
  26
  27 : splice-final ( quot -- nodes ) splice-quot finalize ;
  28
  29 M: #copy finalize* drop f ;
  30
  31 M: #shuffle finalize*
  32     dup {
  33         [ [ in-d>> length ] [ out-d>> length ] bi = ]
  34         [ [ in-r>> length ] [ out-r>> length ] bi = ]
  35         [ [ in-d>> ] [ out-d>> ] [ mapping>> ] tri '[ _ at = ] 2all? ]
  36         [ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at = ] 2all? ]
  37     } 1&& [ drop f ] when ;
  38
  39 MEMO: cached-expansion ( word -- nodes )
  40     def>> splice-final ;
  41
  42 GENERIC: finalize-word ( #call word -- nodes )
  43
  44 M: predicate finalize-word
  45     "predicating" word-prop {
  46         { [ dup builtin-class? ] [ drop word>> cached-expansion ] }
  47         { [ dup tuple-class? ] [ drop word>> def>> splice-final ] }
  48         { [ dup singleton-class? ] [ drop word>> def>> splice-final ] }
  49         [ drop ]
  50     } cond ;
  51
  52 M: math-partial finalize-word
  53     dup primitive? [ drop ] [ nip cached-expansion ] if ;
  54
  55 M: word finalize-word drop ;
  56
  57 M: #call finalize*
  58     dup word>> finalize-word ;
  59
  60 M: node finalize* ;