ae3b0e9add3cbe22bfd9624200ae48b477038a37
[packages/hoopl.git] / testing / ConstProp.hs
1 {-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
2 {-# LANGUAGE ScopedTypeVariables, GADTs #-}
3 module ConstProp (ConstFact, constLattice, initFact, varHasLit, constProp) where
4
5 import qualified Data.Map as M
6 import qualified Data.Map as Map
7
8 import Compiler.Hoopl
9 import IR
10 import OptSupport
11
12 -- ConstFact:
13 -- Not present in map => bottom
14 -- PElem v => variable has value v
15 -- Top => variable's value is not constant
16 -- @ start cprop.tex
17 -- Type and definition of the lattice
18 type ConstFact = Map.Map Var (WithTop Lit)
19 constLattice :: DataflowLattice ConstFact
20 constLattice = DataflowLattice
21 { fact_name = "Const var value"
22 , fact_bot = Map.empty
23 , fact_extend = stdMapJoin (joinWithTop' constFactAdd)
24 , fact_do_logging = False
25 }
26 where
27 constFactAdd _ (OldFact old) (NewFact new)
28 = (changeIf (new /= old), joined)
29 where joined = if new == old then PElem new else Top
30
31 -- @ end cprop.tex
32 -- Initially, we assume that all variable values are unknown.
33 initFact :: [Var] -> ConstFact
34 initFact vars = M.fromList $ [(v, Top) | v <- vars]
35
36 -- Only interesting semantic choice: values of variables are live across
37 -- a call site.
38 -- Note that we don't need a case for x := y, where y holds a constant.
39 -- We can write the simplest solution and rely on the interleaved optimization.
40 -- @ start cprop.tex
41 ----------------------------------------------------------------
42 -- Analysis: variable equals a literal constant
43 varHasLit :: FwdTransfer Insn ConstFact
44 varHasLit = mkFTransfer' v
45 where
46 v :: Insn e x -> ConstFact -> Fact x ConstFact
47 v (Label _) f = f
48 v (Assign x (Lit l)) f = M.insert x (PElem l) f
49 v (Assign x _) f = M.insert x Top f
50 v (Store _ _) f = f
51 v (Branch bid) f = mkFactBase [(bid, f)]
52 v (Cond (Var x) tid fid) f
53 = mkFactBase [(tid, Map.insert x (b True) f),
54 (fid, Map.insert x (b False) f)]
55 where b = PElem . Bool
56 v (Cond _ tid fid) f
57 = mkFactBase [(tid, f), (fid, f)]
58
59 -- @ end cprop.tex
60 v (Call vs _ _ bid) f = mkFactBase [(bid, foldl toTop f vs)]
61 where toTop f v = M.insert v Top f
62 v (Return _) _ = mkFactBase []
63
64 -- @ start cprop.tex
65 ----------------------------------------------------------------
66 -- Rewriting: propagate and fold constants
67 constProp :: Monad m => FwdRewrite m Insn ConstFact
68 constProp = shallowFwdRwPoly cp
69 where
70 cp node facts = return $ fmap insnToG $ (map_EN . map_EE . map_VE) lookup node
71 where lookup v = case M.lookup v facts of
72 Just (PElem l) -> Just $ Lit l
73 _ -> Nothing