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

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