core/compiler/optimizer/kill-literals.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 kernel math
   5 namespaces sequences words ;
   6
   7 : node-union ( node quot -- hash )
   8     [
   9         swap [ swap call [ dup set ] each ] each-node-with
  10     ] make-hash ; inline
  11
  12 GENERIC: literals* ( node -- seq )
  13
  14 : literals ( node -- hash )
  15     [ literals* ] node-union ;
  16
  17 GENERIC: live-values* ( node -- seq )
  18
  19 : live-values ( node -- hash )
  20     #! All values that are returned or passed to calls.
  21     [ live-values* ] node-union ;
  22
  23 : kill-node* ( values node -- )
  24     2dup [ node-in-d remove-all ] keep set-node-in-d
  25     2dup [ node-out-d remove-all ] keep set-node-out-d
  26     2dup [ node-in-r remove-all ] keep set-node-in-r
  27     [ node-out-r remove-all ] keep set-node-out-r ;
  28
  29 : kill-node ( values node -- )
  30     over hash-empty?
  31     [ 2drop ] [ [ kill-node* ] each-node-with ] if ;
  32
  33 : kill-values ( node -- )
  34     dup live-values over literals hash-diff swap kill-node ;
  35
  36 ! Generic nodes
  37 M: node literals* drop { } ;
  38
  39 M: node live-values*
  40     node-in-d [ value? ] subset ;
  41
  42 ! #push
  43 M: #push literals* node-out-d ;
  44
  45 ! #return
  46 M: #return live-values*
  47     #! Values returned by local labels can be killed.
  48     dup node-param [ drop { } ] [ delegate live-values* ] if ;
  49
  50 ! nodes that don't use their values directly
  51 UNION: #killable
  52     #push #shuffle #>r #r> #call-label #merge #values #entry ;
  53
  54 M: #killable live-values* drop { } ;
  55
  56 : purge-invariants ( stacks -- seq )
  57     #! Output a sequence of values which are not present in the
  58     #! same position in each sequence of the stacks sequence.
  59     unify-lengths flip [ all-eq? not ] subset concat ;
  60
  61 ! #label
  62 M: #label live-values*
  63     dup node-child node-in-d over node-in-d 2array
  64     swap collect-recursion append purge-invariants ;
  65
  66 ! branching
  67 UNION: #branch #if #dispatch ;
  68
  69 M: #branch live-values*
  70     #! This assumes that the last element of each branch is a
  71     #! #return node.
  72     dup delegate live-values* >r
  73     node-children [ last-node node-in-d ] map purge-invariants
  74     r> append ;