basis/compiler/tree/identities/identities.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators compiler.tree
   4 compiler.tree.combinators compiler.tree.propagation.info fry
   5 hashtables kernel math math.partial-dispatch sequences words ;
   6 IN: compiler.tree.identities
   7
   8 : define-identities ( word identities -- )
   9     [ integer-derived-ops dup empty? f assert= ] dip
  10     '[ _ "identities" set-word-prop ] each ;
  11
  12 SYMBOL: X
  13
  14 \ + {
  15     { { X 0 } drop }
  16     { { 0 X } nip }
  17 } define-identities
  18
  19 \ - {
  20     { { X 0 } drop }
  21 } define-identities
  22
  23 \ * {
  24     { { X 1 } drop }
  25     { { 1 X } nip }
  26     { { X 0 } nip }
  27     { { 0 X } drop }
  28 } define-identities
  29
  30 \ bitand {
  31     { { X -1 } drop }
  32     { { -1 X } nip }
  33     { { X 0 } nip }
  34     { { 0 X } drop }
  35 } define-identities
  36
  37 \ bitor {
  38     { { X 0 } drop }
  39     { { 0 X } nip }
  40     { { X -1 } nip }
  41     { { -1 X } drop }
  42 } define-identities
  43
  44 \ bitxor {
  45     { { X 0 } drop }
  46     { { 0 X } nip }
  47 } define-identities
  48
  49 \ shift {
  50     { { 0 X } drop }
  51     { { X 0 } drop }
  52 } define-identities
  53
  54 : matches? ( pattern infos -- ? )
  55     [ over X eq? [ 2drop t ] [ literal>> = ] if ] 2all? ;
  56
  57 : find-identity ( patterns infos -- result )
  58     '[ first _ matches? ] find swap [ second ] when ;
  59
  60 GENERIC: apply-identities* ( node -- node )
  61
  62 : simplify-to-constant ( #call constant -- nodes )
  63     [ [ in-d>> <#drop> ] [ out-d>> first ] bi ] dip swap <#push>
  64     2array ;
  65
  66 : select-input ( node n -- #shuffle )
  67     [ [ in-d>> ] [ out-d>> ] bi ] dip
  68     pick nth over first associate <#data-shuffle> ;
  69
  70 M: #call apply-identities*
  71     dup word>> "identities" word-prop [
  72         over node-input-infos find-identity [
  73             {
  74                 { \ drop [ 0 select-input ] }
  75                 { \ nip [ 1 select-input ] }
  76                 [ simplify-to-constant ]
  77             } case
  78         ] when*
  79     ] when* ;
  80
  81 M: node apply-identities* ;
  82
  83 : apply-identities ( nodes -- nodes' )
  84     [ apply-identities* ] map-nodes ;