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