basis/compiler/cfg/stacks/padding/padding.factor

   1 ! Copyright (C) 2015 Björn Lindqvist.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs compiler.cfg.dataflow-analysis
   4 compiler.cfg.instructions compiler.cfg.linearization compiler.cfg.registers
   5 compiler.cfg.stacks.local fry kernel math math.order namespaces
   6 sequences ;
   7 QUALIFIED: sets
   8 IN: compiler.cfg.stacks.padding
   9
  10 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  11 ! !! Stack
  12 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  13
  14 : register-write ( n stack -- stack' )
  15     first2 swapd remove 2array ;
  16
  17 : combine-stacks ( stacks -- stack )
  18     [ first first ] [ [ second ] map sets:combine ] bi 2array ;
  19
  20 : classify-read ( stack n -- val )
  21     swap 2dup second member? [ 2drop 2 ] [ first >= [ 1 ] [ 0 ] if ] if ;
  22
  23 : shift-stack ( n stack -- stack' )
  24     first2 pick '[ _ + ] map [ 0 >= ] filter pick 0 max iota sets:union
  25     [ + ] dip 2array ;
  26
  27 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  28 ! !! States
  29 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  30 ERROR: vacant-when-calling seq ;
  31
  32 CONSTANT: initial-state { { 0 { } } { 0 { } } }
  33
  34 : apply-stack-op ( state insn quote: ( n stack -- stack' ) -- state' )
  35     [ [ first2 ] dip loc>> >loc< ] dip
  36     [ '[ rot @ swap ] ] [ '[ swap @ ] ] bi if 2array ; inline
  37
  38 : combine-states ( states -- state )
  39     [ initial-state ] [ flip [ combine-stacks ] map ] if-empty ;
  40
  41 : live-location ( state insn -- state' )
  42     [ register-write ] apply-stack-op ;
  43
  44 : ensure-no-vacant ( state -- )
  45     [ second ] map dup { { } { } } = [ drop ] [ throw-vacant-when-calling ] if ;
  46
  47 : all-live ( state -- state' )
  48     [ first { } 2array ] map ;
  49
  50 GENERIC: visit-insn ( state insn -- state' )
  51
  52 M: ##inc visit-insn ( state insn -- state' )
  53     [ shift-stack ] apply-stack-op ;
  54
  55 M: ##replace-imm visit-insn live-location ;
  56 M: ##replace visit-insn live-location ;
  57
  58 M: ##call visit-insn ( state insn -- state' )
  59     drop dup ensure-no-vacant ;
  60
  61 M: ##call-gc visit-insn ( state insn -- state' )
  62     drop all-live ;
  63
  64 M: gc-map-insn visit-insn ( state insn -- state' )
  65     drop ;
  66
  67 ERROR: vacant-peek insn ;
  68
  69 : underflowable-peek? ( state peek -- ? )
  70     2dup loc>> >loc< swap [ 0 1 ? swap nth ] dip classify-read
  71     dup 2 = [ drop throw-vacant-peek ] [ 2nip 1 = ] if ;
  72
  73 M: ##peek visit-insn ( state insn -- state )
  74     dup loc>> n>> 0 >= t assert=
  75     dupd underflowable-peek? [ all-live ] when ;
  76
  77 M: insn visit-insn ( state insn -- state' )
  78     drop ;
  79
  80 FORWARD-ANALYSIS: padding
  81
  82 SYMBOL: stack-record
  83
  84 : register-stack-state ( state insn -- )
  85     insn#>> stack-record get set-at ;
  86
  87 : visit-insns ( insns state -- state' )
  88     [ [ register-stack-state ] [ visit-insn ] 2bi ] reduce ;
  89
  90 M: padding-analysis transfer-set ( in-set bb dfa -- out-set )
  91     drop instructions>> swap visit-insns ;
  92
  93 M: padding-analysis ignore-block? ( bb dfa -- ? )
  94     2drop f ;
  95
  96 M: padding-analysis join-sets ( sets bb dfa -- set )
  97     2drop combine-states ;
  98
  99 : uniquely-number-instructions ( cfg -- )
 100     cfg>insns [ swap insn#<< ] each-index ;
 101
 102 : trace-stack-state2 ( cfg -- assoc )
 103     H{ } clone stack-record set
 104     [ uniquely-number-instructions ] [ compute-padding-sets ] bi
 105     stack-record get ;