basis/compiler/cfg/linear-scan/resolve/resolve.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators
   4 combinators.short-circuit fry kernel locals namespaces
   5 make math sequences hashtables
   6 compiler.cfg
   7 compiler.cfg.rpo
   8 compiler.cfg.liveness
   9 compiler.cfg.registers
  10 compiler.cfg.utilities
  11 compiler.cfg.instructions
  12 compiler.cfg.predecessors
  13 compiler.cfg.parallel-copy
  14 compiler.cfg.linear-scan.assignment
  15 compiler.cfg.linear-scan.allocation.state ;
  16 IN: compiler.cfg.linear-scan.resolve
  17
  18 SYMBOL: spill-temps
  19
  20 : spill-temp ( rep -- n )
  21     spill-temps get [ next-spill-slot ] cache ;
  22
  23 : add-mapping ( from to rep -- )
  24     '[ _ 2array ] bi@ 2array , ;
  25
  26 :: resolve-value-data-flow ( bb to vreg -- )
  27     vreg bb vreg-at-end
  28     vreg to vreg-at-start
  29     2dup = [ 2drop ] [ vreg rep-of add-mapping ] if ;
  30
  31 : compute-mappings ( bb to -- mappings )
  32     dup live-in dup assoc-empty? [ 3drop f ] [
  33         [ keys [ resolve-value-data-flow ] with with each ] { } make
  34     ] if ;
  35
  36 : memory->register ( from to -- )
  37     swap [ first2 ] [ first n>> ] bi* _reload ;
  38
  39 : register->memory ( from to -- )
  40     [ first2 ] [ first n>> ] bi* _spill ;
  41
  42 : temp->register ( from to -- )
  43     nip [ first ] [ second ] [ second spill-temp ] tri _reload ;
  44
  45 : register->temp ( from to -- )
  46     drop [ first2 ] [ second spill-temp ] bi _spill ;
  47
  48 : register->register ( from to -- )
  49     swap [ first ] [ first2 ] bi* ##copy ;
  50
  51 SYMBOL: temp
  52
  53 : >insn ( from to -- )
  54     {
  55         { [ over temp eq? ] [ temp->register ] }
  56         { [ dup temp eq? ] [ register->temp ] }
  57         { [ over first spill-slot? ] [ memory->register ] }
  58         { [ dup first spill-slot? ] [ register->memory ] }
  59         [ register->register ]
  60     } cond ;
  61
  62 : mapping-instructions ( alist -- insns )
  63     [ swap ] H{ } assoc-map-as
  64     [ temp [ swap >insn ] parallel-mapping ] { } make ;
  65
  66 : perform-mappings ( bb to mappings -- )
  67     dup empty? [ 3drop ] [
  68         mapping-instructions insert-simple-basic-block
  69         cfg get cfg-changed drop
  70     ] if ;
  71
  72 : resolve-edge-data-flow ( bb to -- )
  73     2dup compute-mappings perform-mappings ;
  74
  75 : resolve-block-data-flow ( bb -- )
  76     dup successors>> [ resolve-edge-data-flow ] with each ;
  77
  78 : resolve-data-flow ( cfg -- )
  79     needs-predecessors
  80
  81     H{ } clone spill-temps set
  82     [ resolve-block-data-flow ] each-basic-block ;