core/optimizer/known-words/known-words.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: optimizer.known-words
   4 USING: alien arrays generic hashtables inference.dataflow
   5 inference.class kernel assocs math math.order math.private
   6 kernel.private sequences words parser vectors strings sbufs io
   7 namespaces assocs quotations sequences.private io.binary
   8 io.streams.string layouts splitting math.intervals
   9 math.floats.private classes.tuple classes.tuple.private classes
  10 classes.algebra optimizer.def-use optimizer.backend
  11 optimizer.pattern-match optimizer.inlining float-arrays
  12 sequences.private combinators byte-arrays byte-vectors ;
  13
  14 { <tuple> <tuple-boa> } [
  15     [
  16         dup node-in-d peek node-literal
  17         dup tuple-layout? [ layout-class ] [ drop tuple ] if
  18         1array f
  19     ] "output-classes" set-word-prop
  20 ] each
  21
  22 \ new [
  23     dup node-in-d peek node-literal
  24     dup class? [ drop tuple ] unless 1array f
  25 ] "output-classes" set-word-prop
  26
  27 ! the output of clone has the same type as the input
  28 { clone (clone) } [
  29     [
  30         node-in-d [ value-class* ] map f
  31     ] "output-classes" set-word-prop
  32 ] each
  33
  34 ! not [ A ] [ B ] if ==> [ B ] [ A ] if
  35 : flip-branches? ( #call -- ? ) sole-consumer #if? ;
  36
  37 : (flip-branches) ( #if -- )
  38     dup node-children reverse swap set-node-children ;
  39
  40 : flip-branches ( #call -- #if )
  41     #! If a not is followed by an #if, flip branches and
  42     #! remove the not.
  43     dup sole-consumer (flip-branches) [ ] f splice-quot ;
  44
  45 \ not {
  46     { [ dup flip-branches? ] [ flip-branches ] }
  47 } define-optimizers
  48
  49 ! eq? on objects of disjoint types is always f
  50 : disjoint-eq? ( node -- ? )
  51     node-input-classes first2 2dup and
  52     [ classes-intersect? not ] [ 2drop f ] if ;
  53
  54 \ eq? {
  55     { [ dup disjoint-eq? ] [ [ f ] inline-literals ] }
  56 } define-optimizers
  57
  58 : literal-member? ( #call -- ? )
  59     node-in-d peek dup value?
  60     [ value-literal sequence? ] [ drop f ] if ;
  61
  62 : expand-member ( #call quot -- )
  63     >r dup node-in-d peek value-literal r> call f splice-quot ;
  64
  65 : bit-member-n 256 ; inline
  66
  67 : bit-member? ( seq -- ? )
  68     #! Can we use a fast byte array test here?
  69     {
  70         { [ dup length 8 < ] [ f ] }
  71         { [ dup [ integer? not ] contains? ] [ f ] }
  72         { [ dup [ 0 < ] contains? ] [ f ] }
  73         { [ dup [ bit-member-n >= ] contains? ] [ f ] }
  74         [ t ]
  75     } cond nip ;
  76
  77 : bit-member-seq ( seq -- flags )
  78     bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ;
  79
  80 : exact-float? ( f -- ? )
  81     dup float? [ dup >integer >float = ] [ drop f ] if ; inline
  82
  83 : bit-member-quot ( seq -- newquot )
  84     [
  85         [ drop ] % ! drop the sequence itself; we don't use it at run time
  86         bit-member-seq ,
  87         [
  88             {
  89                 { [ over fixnum? ] [ ?nth 1 eq? ] }
  90                 { [ over bignum? ] [ ?nth 1 eq? ] }
  91                 { [ over exact-float? ] [ ?nth 1 eq? ] }
  92                 [ 2drop f ]
  93             } cond
  94         ] %
  95     ] [ ] make ;
  96
  97 : member-quot ( seq -- newquot )
  98     dup bit-member? [
  99         bit-member-quot
 100     ] [
 101         [ literalize [ t ] ] { } map>assoc
 102         [ drop f ] suffix [ nip case ] curry
 103     ] if ;
 104
 105 \ member? {
 106     { [ dup literal-member? ] [ [ member-quot ] expand-member ] }
 107 } define-optimizers
 108
 109 : memq-quot ( seq -- newquot )
 110     [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
 111     [ drop f ] suffix [ nip cond ] curry ;
 112
 113 \ memq? {
 114     { [ dup literal-member? ] [ [ memq-quot ] expand-member ] }
 115 } define-optimizers
 116
 117 ! if the result of eq? is t and the second input is a literal,
 118 ! the first input is equal to the second
 119 \ eq? [
 120     dup node-in-d second dup value? [
 121         swap [
 122             value-literal 0 `input literal,
 123             \ f class-not 0 `output class,
 124         ] set-constraints
 125     ] [
 126         2drop
 127     ] if
 128 ] "constraints" set-word-prop
 129
 130 ! eq? on the same object is always t
 131 { eq? = } {
 132     { { @ @ } [ 2drop t ] }
 133 } define-identities
 134
 135 ! Specializers
 136 { first first2 first3 first4 }
 137 [ { array } "specializer" set-word-prop ] each
 138
 139 { peek pop* pop push } [
 140     { vector } "specializer" set-word-prop
 141 ] each
 142
 143 \ push-all
 144 { { string sbuf } { array vector } { byte-array byte-vector } }
 145 "specializer" set-word-prop
 146
 147 \ append
 148 { { string string } { array array } }
 149 "specializer" set-word-prop
 150
 151 \ subseq
 152 { { fixnum fixnum string } { fixnum fixnum array } }
 153 "specializer" set-word-prop
 154
 155 \ reverse-here
 156 { { string } { array } }
 157 "specializer" set-word-prop
 158
 159 \ mismatch
 160 { string string }
 161 "specializer" set-word-prop
 162
 163 \ find-last-sep { string sbuf } "specializer" set-word-prop
 164
 165 \ >string { sbuf } "specializer" set-word-prop
 166
 167 \ >array { { string } { vector } } "specializer" set-word-prop
 168
 169 \ >vector { { array } { vector } } "specializer" set-word-prop
 170
 171 \ >sbuf { string } "specializer" set-word-prop
 172
 173 \ split, { string string } "specializer" set-word-prop
 174
 175 \ memq? { array } "specializer" set-word-prop
 176
 177 \ member? { fixnum string } "specializer" set-word-prop
 178
 179 \ assoc-stack { vector } "specializer" set-word-prop
 180
 181 \ >le { { fixnum fixnum } { bignum fixnum } } "specializer" set-word-prop
 182
 183 \ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop