core/compiler/optimizer/call-optimizers.factor

   1 ! Copyright (C) 2005, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: optimizer
   4 USING: arrays errors generic hashtables inference kernel
   5 math math-internals sequences words parser ;
   6
   7 ! A system for associating dataflow optimizers with words.
   8
   9 : optimizer-hooks ( node -- conditions )
  10     node-param "optimizer-hooks" word-prop ;
  11
  12 : optimize-hooks ( node -- node/t )
  13     dup optimizer-hooks cond ;
  14
  15 : define-optimizers ( word optimizers -- )
  16     { [ t ] [ drop t ] } add "optimizer-hooks" set-word-prop ;
  17
  18 : partial-eval? ( #call -- ? )
  19     dup node-param "foldable" word-prop [
  20         dup node-in-d [ node-literal? ] all-with?
  21     ] [
  22         drop f
  23     ] if ;
  24
  25 : literal-in-d ( #call -- inputs )
  26     dup node-in-d [ node-literal ] map-with ;
  27
  28 : partial-eval ( #call -- node )
  29     dup literal-in-d over node-param
  30     [ with-datastack ] catch
  31     [ 3drop t ] [ inline-literals ] if ;
  32
  33 : call>no-op ( not -- node/f )
  34     #! Note: cloning the vectors, since subst-values will modify
  35     #! them.
  36     [ node-in-d clone ] keep
  37     [ node-out-d clone ] keep
  38     [ subst-values ] keep node-successor ;
  39
  40 : flip-branches ( not -- #if )
  41     #! If a not is followed by an #if, flip branches and
  42     #! remove the not.
  43     call>no-op dup
  44     dup node-children reverse swap set-node-children ;
  45
  46 ! An if following a not flips the two branches
  47 \ not {
  48     { [ dup node-successor #if? ] [ flip-branches ] }
  49 } define-optimizers
  50
  51 ! eq? on objects of disjoint types is always f
  52 : disjoint-eq? ( node -- ? )
  53     dup node-classes swap node-in-d
  54     [ swap ?hash ] map-with
  55     first2 2dup and [ classes-intersect? not ] [ 2drop f ] if ;
  56
  57 \ eq? {
  58     { [ dup disjoint-eq? ] [ [ f ] inline-literals ] }
  59 } define-optimizers
  60
  61 ! type applied to an object of a known type can be folded
  62 : known-type? ( node -- ? )
  63     0 node-class# types length 1 number= ;
  64
  65 : fold-known-type ( node -- node )
  66     dup 0 node-class# types first 1array inline-literals ;
  67
  68 \ type [
  69     { [ dup known-type? ] [ fold-known-type ] }
  70 ] define-optimizers
  71
  72 ! Arithmetic identities
  73 SYMBOL: @
  74
  75 : define-identities ( words identities -- )
  76     swap [ swap "identities" set-word-prop ] each-with ;
  77
  78 : literals-match? ( values template -- ? )
  79     [
  80         over value? [ >r value-literal r> ] [ nip @ ] if =
  81     ] 2map [ ] all? ;
  82
  83 : values-match? ( values template -- ? )
  84     [ @ = [ drop f ] unless ] 2map [ ] subset all-eq? ;
  85
  86 : apply-identity? ( values identity -- ? )
  87     first 2dup literals-match? >r values-match? r> and ;
  88
  89 : find-identity ( node -- values identity )
  90     dup node-in-d swap node-param "identities" word-prop
  91     [ dupd apply-identity? ] find nip ;
  92
  93 : apply-identities ( node -- node/f )
  94     dup find-identity dup [
  95         second swap dataflow-with [ subst-node ] keep
  96     ] [
  97         3drop f
  98     ] if ;
  99
 100 [ + fixnum+ bignum+ float+ ] {
 101     { { @ 0 } [ drop ] }
 102     { { 0 @ } [ nip ]  }
 103 } define-identities
 104
 105 [ - fixnum- bignum- float- ] {
 106     { { @ 0 } [ drop ]    }
 107     { { @ @ } [ 2drop 0 ] }
 108 } define-identities
 109
 110 [ * fixnum* bignum* float* ] {
 111     { { @ 1 }  [ drop ]          }
 112     { { 1 @ }  [ nip ]           }
 113     { { @ 0 }  [ nip ]           }
 114     { { 0 @ }  [ drop ]          }
 115     { { @ -1 } [ drop 0 swap - ] }
 116     { { -1 @ } [ nip 0 swap - ]  }
 117 } define-identities
 118
 119 [ / fixnum/i bignum/i float/f ] {
 120     { { @ 1 }  [ drop ]          }
 121     { { @ -1 } [ drop 0 swap - ] }
 122 } define-identities
 123
 124 [ fixnum-mod bignum-mod ] {
 125     { { @ 1 }  [ 2drop 0 ] }
 126 } define-identities
 127
 128 [ bitand fixnum-bitand bignum-bitand ] {
 129     { { @ -1 } [ drop ] }
 130     { { -1 @ } [ nip  ] }
 131     { { @ @ }  [ drop ] }
 132     { { @ 0 }  [ nip  ] }
 133     { { 0 @ }  [ drop ] }
 134 } define-identities
 135
 136 [ bitor fixnum-bitor bignum-bitor ] {
 137     { { @ 0 }  [ drop ] }
 138     { { 0 @ }  [ nip  ] }
 139     { { @ @ }  [ drop ] }
 140     { { @ -1 } [ nip  ] }
 141     { { -1 @ } [ drop ] }
 142 } define-identities
 143
 144 [ bitxor fixnum-bitxor bignum-bitxor ] {
 145     { { @ 0 }  [ drop ]        }
 146     { { 0 @ }  [ nip  ]        }
 147     { { @ -1 } [ drop bitnot ] }
 148     { { -1 @ } [ nip  bitnot ] }
 149     { { @ @ }  [ 2drop 0 ]     }
 150 } define-identities
 151
 152 [ shift fixnum-shift bignum-shift ] {
 153     { { 0 @ } [ drop ] }
 154     { { @ 0 } [ drop ] }
 155 } define-identities
 156
 157 [ < fixnum< bignum< float< ] {
 158     { { @ @ } [ 2drop f ] }
 159 } define-identities
 160
 161 [ <= fixnum<= bignum<= float<= ] {
 162     { { @ @ } [ 2drop t ] }
 163 } define-identities
 164
 165 [ > fixnum> bignum> float>= ] {
 166     { { @ @ } [ 2drop f ] }
 167 } define-identities
 168
 169 [ >= fixnum>= bignum>= float>= ] {
 170     { { @ @ } [ 2drop t ] }
 171 } define-identities
 172
 173 [ eq? bignum= float= number= = ] {
 174     { { @ @ } [ 2drop t ] }
 175 } define-identities
 176
 177 M: #call optimize-node*
 178     {
 179         { [ dup partial-eval? ] [ partial-eval ] }
 180         { [ dup find-identity nip ] [ apply-identities ] }
 181         { [ dup optimizer-hooks ] [ optimize-hooks ] }
 182         { [ dup optimize-predicate? ] [ optimize-predicate ] }
 183         { [ t ] [ inline-method ] }
 184     } cond ;