basis/compiler/tree/finalization/finalization.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs classes classes.builtin
   4 classes.singleton classes.tuple combinators
   5 combinators.short-circuit compiler.tree
   6 compiler.tree.combinators compiler.tree.late-optimizations fry
   7 kernel math.partial-dispatch memoize sequences
   8 stack-checker.dependencies words ;
   9 IN: compiler.tree.finalization
  10
  11 GENERIC: finalize* ( node -- nodes )
  12
  13 : finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;
  14
  15 : splice-final ( quot -- nodes ) splice-quot finalize ;
  16
  17 : splice-predicate ( word -- nodes )
  18     [ +definition+ depends-on ] [ def>> splice-final ] bi ;
  19
  20 M: #copy finalize* drop f ;
  21
  22 M: #shuffle finalize*
  23     dup {
  24         [ [ in-d>> length ] [ out-d>> length ] bi = ]
  25         [ [ in-r>> length ] [ out-r>> length ] bi = ]
  26         [ [ in-d>> ] [ out-d>> ] [ mapping>> ] tri '[ _ at = ] 2all? ]
  27         [ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at = ] 2all? ]
  28     } 1&& [ drop f ] when ;
  29
  30 MEMO: cached-expansion ( word -- nodes )
  31     def>> splice-final ;
  32
  33 GENERIC: finalize-word ( #call word -- nodes )
  34
  35 M: predicate finalize-word
  36     "predicating" word-prop {
  37         { [ dup builtin-class? ] [ drop word>> cached-expansion ] }
  38         { [ dup tuple-class? ] [ drop word>> splice-predicate ] }
  39         { [ dup singleton-class? ] [ drop word>> splice-predicate ] }
  40         [ drop ]
  41     } cond ;
  42
  43 M: math-partial finalize-word
  44     dup primitive? [ drop ] [ nip cached-expansion ] if ;
  45
  46 M: word finalize-word drop ;
  47
  48 M: #call finalize*
  49     dup word>> finalize-word ;
  50
  51 M: node finalize* ;