basis/optimizer/math/partial/partial.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel kernel.private math math.private words
   4 sequences parser namespaces assocs quotations arrays
   5 generic generic.math hashtables effects ;
   6 IN: optimizer.math.partial
   7
   8 ! Partial dispatch.
   9
  10 ! This code will be overhauled and generalized when
  11 ! multi-methods go into the core.
  12 PREDICATE: math-partial < word
  13     "derived-from" word-prop >boolean ;
  14
  15 : fixnum-integer-op ( a b fix-word big-word -- c )
  16     pick tag 0 eq? [
  17         drop execute
  18     ] [
  19         >r drop >r fixnum>bignum r> r> execute
  20     ] if ; inline
  21
  22 : integer-fixnum-op ( a b fix-word big-word -- c )
  23     >r pick tag 0 eq? [
  24         r> drop execute
  25     ] [
  26         drop fixnum>bignum r> execute
  27     ] if ; inline
  28
  29 : integer-integer-op ( a b fix-word big-word -- c )
  30     pick tag 0 eq? [
  31         integer-fixnum-op
  32     ] [
  33         >r drop over tag 0 eq? [
  34             >r fixnum>bignum r> r> execute
  35         ] [
  36             r> execute
  37         ] if
  38     ] if ; inline
  39
  40 <<
  41 : integer-op-combinator ( triple -- word )
  42     [
  43         [ second name>> % "-" % ]
  44         [ third name>> % "-op" % ]
  45         bi
  46     ] "" make in get lookup ;
  47
  48 : integer-op-word ( triple fix-word big-word -- word )
  49     [
  50         drop
  51         name>> "fast" tail? >r
  52         [ "-" % ] [ name>> % ] interleave
  53         r> [ "-fast" % ] when
  54     ] "" make in get create ;
  55
  56 : integer-op-quot ( word fix-word big-word -- quot )
  57     rot integer-op-combinator 1quotation 2curry ;
  58
  59 : define-integer-op-word ( word fix-word big-word -- )
  60     [
  61         [ integer-op-word ] [ integer-op-quot ] 3bi
  62         (( x y -- z )) define-declared
  63     ]
  64     [
  65         [ integer-op-word ] [ 2drop ] 3bi
  66         "derived-from" set-word-prop
  67     ] 3bi ;
  68
  69 : define-integer-op-words ( words fix-word big-word -- )
  70     [ define-integer-op-word ] 2curry each ;
  71
  72 : integer-op-triples ( word -- triples )
  73     {
  74         { fixnum integer }
  75         { integer fixnum }
  76         { integer integer }
  77     } swap [ prefix ] curry map ;
  78
  79 : define-integer-ops ( word fix-word big-word -- )
  80     >r >r integer-op-triples r> r>
  81     [ define-integer-op-words ]
  82     [ [ 2drop ] [ [ integer-op-word ] 2curry map ] 3bi zip % ]
  83     3bi ;
  84
  85 : define-math-ops ( op -- )
  86     { fixnum bignum float }
  87     [ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc
  88     [ nip ] assoc-filter
  89     [ def>> peek ] assoc-map % ;
  90
  91 SYMBOL: math-ops
  92
  93 [
  94     \ +       define-math-ops
  95     \ -       define-math-ops
  96     \ *       define-math-ops
  97     \ shift   define-math-ops
  98     \ mod     define-math-ops
  99     \ /i      define-math-ops
 100
 101     \ bitand  define-math-ops
 102     \ bitor   define-math-ops
 103     \ bitxor  define-math-ops
 104
 105     \ <       define-math-ops
 106     \ <=      define-math-ops
 107     \ >       define-math-ops
 108     \ >=      define-math-ops
 109     \ number= define-math-ops
 110
 111     \ + \ fixnum+ \ bignum+ define-integer-ops
 112     \ - \ fixnum- \ bignum- define-integer-ops
 113     \ * \ fixnum* \ bignum* define-integer-ops
 114     \ shift \ fixnum-shift \ bignum-shift define-integer-ops
 115     \ mod \ fixnum-mod \ bignum-mod define-integer-ops
 116     \ /i \ fixnum/i \ bignum/i define-integer-ops
 117
 118     \ bitand \ fixnum-bitand \ bignum-bitand define-integer-ops
 119     \ bitor \ fixnum-bitor \ bignum-bitor define-integer-ops
 120     \ bitxor \ fixnum-bitxor \ bignum-bitxor define-integer-ops
 121
 122     \ < \ fixnum< \ bignum< define-integer-ops
 123     \ <= \ fixnum<= \ bignum<= define-integer-ops
 124     \ > \ fixnum> \ bignum> define-integer-ops
 125     \ >= \ fixnum>= \ bignum>= define-integer-ops
 126     \ number= \ eq? \ bignum= define-integer-ops
 127 ] { } make >hashtable math-ops set-global
 128
 129 SYMBOL: fast-math-ops
 130
 131 [
 132     { { + fixnum fixnum } fixnum+fast } ,
 133     { { - fixnum fixnum } fixnum-fast } ,
 134     { { * fixnum fixnum } fixnum*fast } ,
 135     { { shift fixnum fixnum } fixnum-shift-fast } ,
 136
 137     \ + \ fixnum+fast \ bignum+ define-integer-ops
 138     \ - \ fixnum-fast \ bignum- define-integer-ops
 139     \ * \ fixnum*fast \ bignum* define-integer-ops
 140     \ shift \ fixnum-shift-fast \ bignum-shift define-integer-ops
 141 ] { } make >hashtable fast-math-ops set-global
 142
 143 >>
 144
 145 : math-op ( word left right -- word' ? )
 146     3array math-ops get at* ;
 147
 148 : math-method* ( word left right -- quot )
 149     3dup math-op
 150     [ >r 3drop r> 1quotation ] [ drop math-method ] if ;
 151
 152 : math-both-known? ( word left right -- ? )
 153     3dup math-op
 154     [ 2drop 2drop t ]
 155     [ drop math-class-max swap specific-method >boolean ] if ;
 156
 157 : (derived-ops) ( word assoc -- words )
 158     swap [ rot first eq? nip ] curry assoc-filter values ;
 159
 160 : derived-ops ( word -- words )
 161     [ 1array ]
 162     [ math-ops get (derived-ops) ]
 163     bi append ;
 164
 165 : fast-derived-ops ( word -- words )
 166     fast-math-ops get (derived-ops) ;
 167
 168 : all-derived-ops ( word -- words )
 169     [ derived-ops ] [ fast-derived-ops ] bi append ;
 170
 171 : each-derived-op ( word quot -- )
 172     >r derived-ops r> each ; inline
 173
 174 : each-fast-derived-op ( word quot -- )
 175     >r fast-derived-ops r> each ; inline