/
ConstProp.hs
83 lines (65 loc) · 2.59 KB
/
ConstProp.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
{-# LANGUAGE ScopedTypeVariables, GADTs, NoMonomorphismRestriction #-}
module ConstProp (ConstFact, constLattice, initFact, varHasLit, constProp, constPropPass, M) where
--import Control.Monad
import Insn
import qualified Data.Map as Map
import Compiler.Hoopl
--import IR
--import OptSupport
-- ConstFact:
-- Not present in map => bottom
-- PElem v => variable has value v
-- Top => variable's value is not constant
-- Type and definition of the lattice
type M = CheckingFuelMonad (SimpleUniqueMonad)
type ConstFact = Map.Map Int (WithTop Expr)
constLattice :: DataflowLattice ConstFact
constLattice = DataflowLattice
{ fact_name = "Constant propagation"
, fact_bot = Map.empty
, fact_join = joinMaps (extendJoinDomain constFactAdd) }
where
constFactAdd _ (OldFact old) (NewFact new)
= if new == old then (NoChange, PElem new)
else (SomeChange, Top)
-- Initially, we assume that all variable values are unknown.
-- Only interesting semantic choice: values of variables are live across
-- a call site.
-- Note that we don't need a case for x := y, where y holds a constant.
-- We can write the simplest solution and rely on the interleaved optimization.
--------------------------------------------------
-- Analysis: variable equals a literal constant
varHasLit :: FwdTransfer Insn ConstFact
varHasLit = mkFTransfer ft
where
ft :: Insn e x -> ConstFact -> Fact x ConstFact
ft (BifPlus reg _ _) f = Map.insert reg Top f
ft (Subcall reg _) f = Map.insert reg Top f
ft (Fetch reg _) f = Map.insert reg Top f
ft (RegSet reg constant@(Double _)) f = Map.insert reg (PElem constant) f
ft (RegSet reg _) f = Map.insert reg Top f
constPropPass :: FwdPass M Insn ConstFact
constPropPass = FwdPass
{ fp_lattice = constLattice
, fp_transfer = varHasLit
, fp_rewrite = constProp `thenFwdRw` simplify}
initFact :: ConstFact
initFact = Map.fromList []
singleInsn = return . Just . insnToGraph
constProp :: FuelMonad m => FwdRewrite m Insn ConstFact
constProp = mkFRewrite cp
where
cp :: (Monad m) => Insn e x -> ConstFact -> m (Maybe (Graph Insn e x))
cp insn f = singleInsn $ mapE (lookup f) insn
lookup f reg@(Reg r) = case Map.lookup r f of
Just (PElem c) -> c
_ -> reg
lookup _ x = x
--insnToG :: Insn e x -> Graph Insn e x
simplify :: FuelMonad m => FwdRewrite m Insn ConstFact
simplify = mkFRewrite s
where
s :: (Monad m) => Insn e x -> a -> m (Maybe (Graph Insn e x))
s (BifPlus reg (Double a) (Double b)) _ = singleInsn $ RegSet reg (Double (a+b))
s _ _ = return Nothing