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