core/compiler/optimizer/optimizer.factor

   1 ! Copyright (C) 2004, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: optimizer
   4 USING: arrays generic hashtables inference io kernel math
   5 namespaces sequences test vectors ;
   6
   7 SYMBOL: optimizer-changed
   8
   9 GENERIC: optimize-node* ( node -- node/t )
  10
  11 : keep-optimizing ( node -- node ? )
  12     dup optimize-node* dup t eq?
  13     [ drop f ] [ nip keep-optimizing t or ] if ;
  14
  15 : optimize-node ( node -- node )
  16     [
  17         keep-optimizing [ optimizer-changed on ] when
  18     ] map-nodes ;
  19
  20 : optimize-1 ( node -- node ? )
  21     dup kill-values dup infer-classes [
  22         optimizer-changed off
  23         optimize-node
  24         optimizer-changed get
  25     ] with-node-iterator ;
  26
  27 : optimize ( node -- node )
  28     optimize-1 [ optimize ] when ;
  29
  30 : prune-if ( node quot -- successor/t )
  31     over >r call [ r> node-successor ] [ r> drop t ] if ;
  32     inline
  33
  34 ! Generic nodes
  35 M: f optimize-node* drop t ;
  36
  37 M: node optimize-node* drop t ;
  38
  39 ! #shuffle
  40 M: #shuffle optimize-node*
  41     [ node-values empty? ] prune-if ;
  42
  43 ! #>r
  44 M: #>r optimize-node*
  45     dup node-successor #r>? [
  46         node-successor node-successor
  47     ] [
  48         [ node-in-d empty? ] prune-if
  49     ] if ;
  50
  51 ! #r>
  52 M: #r> optimize-node*
  53     dup node-successor #>r? [
  54         node-successor node-successor
  55     ] [
  56         [ node-in-r empty? ] prune-if
  57     ] if ;
  58
  59 ! #push
  60 M: #push optimize-node*
  61     [ node-out-d empty? ] prune-if ;
  62
  63 ! #return
  64 M: #return optimize-node*
  65     node-successor [ node-successor ] [ t ] if* ;
  66
  67 ! Some utilities for splicing in dataflow IR subtrees
  68 : post-inline ( #return/#values #call/#merge -- )
  69     [
  70         >r node-in-d r> node-out-d 2array unify-lengths first2
  71     ] keep subst-values ;
  72
  73 : ?hash-union ( hash/f hash -- hash )
  74     over [ hash-union ] [ nip ] if ;
  75
  76 : add-node-literals ( hash node -- )
  77     [ node-literals ?hash-union ] keep set-node-literals ;
  78
  79 : add-node-classes ( hash node -- )
  80     [ node-classes ?hash-union ] keep set-node-classes ;
  81
  82 : (subst-classes) ( literals classes node -- )
  83     dup [
  84         3dup [ add-node-classes ] keep add-node-literals
  85         node-successor (subst-classes)
  86     ] [
  87         3drop
  88     ] if ;
  89
  90 : subst-classes ( #return/#values #call/#merge -- )
  91     >r dup node-literals swap node-classes r> (subst-classes) ;
  92
  93 : subst-node ( old new -- )
  94     #! The last node of 'new' becomes 'old', then values are
  95     #! substituted. A subsequent optimizer phase kills the
  96     #! last node of 'new' and the first node of 'old'.
  97     last-node 2dup swap 2dup post-inline subst-classes
  98     set-node-successor ;
  99
 100 ! Constant branch folding
 101 : fold-branch ( node branch# -- node )
 102     over drop-inputs >r
 103     >r dup node-successor r> rot node-children nth
 104     [ subst-node ] keep r> [ set-node-successor ] keep ;
 105
 106 ! #if
 107 : known-boolean-value? ( node value -- value ? )
 108     2dup node-literal? [
 109         node-literal t
 110     ] [
 111         node-class {
 112             { [ dup null class< ] [ drop f f ] }
 113             { [ dup general-t class< ] [ drop t t ] }
 114             { [ dup \ f class< ] [ drop f t ] }
 115             { [ t ] [ drop f f ] }
 116         } cond
 117     ] if ;
 118
 119 M: #if optimize-node*
 120     dup dup node-in-d first known-boolean-value?
 121     [ 0 1 ? fold-branch ] [ 2drop t ] if ;
 122
 123 ! #dispatch
 124 M: #dispatch optimize-node*
 125     dup dup node-in-d first 2dup node-literal? [
 126         node-literal fold-branch
 127     ] [
 128         3drop t
 129     ] if ;