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

   1 ! Copyright (C) 2009, 2010 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 cpu.architecture
   7 compiler.cfg
   8 compiler.cfg.rpo
   9 compiler.cfg.liveness
  10 compiler.cfg.registers
  11 compiler.cfg.utilities
  12 compiler.cfg.instructions
  13 compiler.cfg.predecessors
  14 compiler.cfg.parallel-copy
  15 compiler.cfg.ssa.destruction
  16 compiler.cfg.linear-scan.assignment
  17 compiler.cfg.linear-scan.allocation.state ;
  18 IN: compiler.cfg.linear-scan.resolve
  19
  20 TUPLE: location
  21 { reg read-only }
  22 { rep read-only }
  23 { reg-class read-only } ;
  24
  25 : <location> ( reg rep -- location )
  26     dup reg-class-of location boa ;
  27
  28 M: location equal?
  29     over location? [
  30         { [ [ reg>> ] bi@ = ] [ [ reg-class>> ] bi@ = ] } 2&&
  31     ] [ 2drop f ] if ;
  32
  33 M: location hashcode*
  34     reg>> hashcode* ;
  35
  36 SYMBOL: spill-temps
  37
  38 : spill-temp ( rep -- n )
  39     rep-size spill-temps get [ next-spill-slot ] cache ;
  40
  41 : add-mapping ( from to rep -- )
  42     '[ _ <location> ] bi@ 2array , ;
  43
  44 :: resolve-value-data-flow ( vreg live-out live-in edge-live-in -- )
  45     vreg live-out ?at [ bad-vreg ] unless
  46     vreg live-in ?at [ edge-live-in ?at [ bad-vreg ] unless ] unless
  47     2dup = [ 2drop ] [ vreg rep-of add-mapping ] if ;
  48
  49 :: compute-mappings ( bb to -- mappings )
  50     bb machine-live-out :> live-out
  51     to machine-live-in :> live-in
  52     bb to machine-edge-live-in :> edge-live-in
  53     live-out assoc-empty? [ f ] [
  54         [
  55             live-in keys edge-live-in keys append [
  56                 live-out live-in edge-live-in
  57                 resolve-value-data-flow
  58             ] each
  59         ] { } make
  60     ] if ;
  61
  62 : memory->register ( from to -- )
  63     swap [ reg>> ] [ [ rep>> ] [ reg>> ] bi ] bi* ##reload, ;
  64
  65 : register->memory ( from to -- )
  66     [ [ reg>> ] [ rep>> ] bi ] [ reg>> ] bi* ##spill, ;
  67
  68 : temp->register ( from to -- )
  69     nip [ reg>> ] [ rep>> ] [ rep>> spill-temp ] tri ##reload, ;
  70
  71 : register->temp ( from to -- )
  72     drop [ [ reg>> ] [ rep>> ] bi ] [ rep>> spill-temp ] bi ##spill, ;
  73
  74 : register->register ( from to -- )
  75     swap [ reg>> ] [ [ reg>> ] [ rep>> ] bi ] bi* ##copy, ;
  76
  77 SYMBOL: temp
  78
  79 : >insn ( from to -- )
  80     {
  81         { [ over temp eq? ] [ temp->register ] }
  82         { [ dup temp eq? ] [ register->temp ] }
  83         { [ over reg>> spill-slot? ] [ memory->register ] }
  84         { [ dup reg>> spill-slot? ] [ register->memory ] }
  85         [ register->register ]
  86     } cond ;
  87
  88 : mapping-instructions ( alist -- insns )
  89     [ swap ] H{ } assoc-map-as
  90     [ temp [ swap >insn ] parallel-mapping ##branch, ] { } make ;
  91
  92 : perform-mappings ( bb to mappings -- )
  93     dup empty? [ 3drop ] [
  94         mapping-instructions insert-basic-block
  95         cfg get cfg-changed drop
  96     ] if ;
  97
  98 : resolve-edge-data-flow ( bb to -- )
  99     2dup compute-mappings perform-mappings ;
 100
 101 : resolve-block-data-flow ( bb -- )
 102     dup kill-block?>> [ drop ] [
 103         dup successors>> [ resolve-edge-data-flow ] with each
 104     ] if ;
 105
 106 : resolve-data-flow ( cfg -- )
 107     needs-predecessors
 108
 109     H{ } clone spill-temps set
 110     [ resolve-block-data-flow ] each-basic-block ;