basis/compiler/tree/finalization/finalization.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel arrays accessors sequences sequences.private words
   4 fry namespaces make math math.order memoize classes.builtin
   5 classes.tuple.private slots.private combinators layouts
   6 byte-arrays alien.accessors
   7 compiler.intrinsics
   8 compiler.tree
   9 compiler.tree.builder
  10 compiler.tree.normalization
  11 compiler.tree.propagation
  12 compiler.tree.propagation.info
  13 compiler.tree.cleanup
  14 compiler.tree.def-use
  15 compiler.tree.dead-code
  16 compiler.tree.combinators ;
  17 IN: compiler.tree.finalization
  18
  19 ! This pass runs after propagation, so that it can expand
  20 ! built-in type predicates and memory allocation; these cannot
  21 ! be expanded before propagation since we need to see 'fixnum?'
  22 ! instead of 'tag 0 eq?' and so on, for semantic reasoning.
  23 ! We also delete empty stack shuffles and copies to facilitate
  24 ! tail call optimization in the code generator. After this pass
  25 ! runs, stack flow information is no longer accurate, since we
  26 ! punt in 'splice-quot' and don't update everything that we
  27 ! should; this simplifies the code, improves performance, and we
  28 ! don't need the stack flow information after this pass anyway.
  29
  30 GENERIC: finalize* ( node -- nodes )
  31
  32 M: #copy finalize* drop f ;
  33
  34 M: #shuffle finalize*
  35     dup shuffle-effect
  36     [ in>> ] [ out>> ] bi sequence=
  37     [ drop f ] when ;
  38
  39 : splice-quot ( quot -- nodes )
  40     [
  41         build-tree
  42         normalize
  43         propagate
  44         cleanup
  45         compute-def-use
  46         remove-dead-code
  47         but-last
  48     ] with-scope ;
  49
  50 : builtin-predicate? ( #call -- ? )
  51     word>> "predicating" word-prop builtin-class? ;
  52
  53 MEMO: builtin-predicate-expansion ( word -- nodes )
  54     def>> splice-quot ;
  55
  56 : expand-builtin-predicate ( #call -- nodes )
  57     word>> builtin-predicate-expansion ;
  58
  59 : first-literal ( #call -- obj ) node-input-infos first literal>> ;
  60
  61 : last-literal ( #call -- obj ) node-input-infos peek literal>> ;
  62
  63 : expand-tuple-boa? ( #call -- ? )
  64     dup word>> \ <tuple-boa> eq? [
  65         last-literal tuple-layout?
  66     ] [ drop f ] if ;
  67
  68 MEMO: (tuple-boa-expansion) ( n -- quot )
  69     [
  70         [ 2 + ] map <reversed>
  71         [ '[ [ , set-slot ] keep ] % ] each
  72     ] [ ] make ;
  73
  74 : tuple-boa-expansion ( layout -- quot )
  75     #! No memoization here since otherwise we'd hang on to
  76     #! tuple layout objects.
  77     size>> (tuple-boa-expansion) \ (tuple) prefix splice-quot ;
  78
  79 : expand-tuple-boa ( #call -- node )
  80     last-literal tuple-boa-expansion ;
  81
  82 MEMO: <array>-expansion ( n -- quot )
  83     [
  84         [ swap (array) ] %
  85         [ \ 2dup , , [ swap set-array-nth ] % ] each
  86         \ nip ,
  87     ] [ ] make splice-quot ;
  88
  89 : expand-<array>? ( #call -- ? )
  90     dup word>> \ <array> eq? [
  91         first-literal dup integer?
  92         [ 0 32 between? ] [ drop f ] if
  93     ] [ drop f ] if ;
  94
  95 : expand-<array> ( #call -- node )
  96     first-literal <array>-expansion ;
  97
  98 : bytes>cells ( m -- n ) cell align cell /i ;
  99
 100 MEMO: <byte-array>-expansion ( n -- quot )
 101     [
 102         [ (byte-array) ] %
 103         bytes>cells [ cell * ] map
 104         [ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
 105     ] [ ] make splice-quot ;
 106
 107 : expand-<byte-array>? ( #call -- ? )
 108     dup word>> \ <byte-array> eq? [
 109         first-literal dup integer?
 110         [ 0 128 between? ] [ drop f ] if
 111     ] [ drop f ] if ;
 112
 113 : expand-<byte-array> ( #call -- nodes )
 114     first-literal <byte-array>-expansion ;
 115
 116 M: #call finalize*
 117     {
 118         { [ dup builtin-predicate? ] [ expand-builtin-predicate ] }
 119         { [ dup expand-tuple-boa? ] [ expand-tuple-boa ] }
 120         { [ dup expand-<array>? ] [ expand-<array> ] }
 121         { [ dup expand-<byte-array>? ] [ expand-<byte-array> ] }
 122         [ ]
 123     } cond ;
 124
 125 M: node finalize* ;
 126
 127 : finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;