Constant-propagation figure is now extracted automatically from John's code; some...
[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 type Node = Insn -- for paper
13
14 -- ConstFact:
15 -- Not present in map => bottom
16 -- PElem v => variable has value v
17 -- Top => variable's value is not constant
18 -- @ start cprop.tex
19 -- Type and definition of the lattice
20 type ConstFact = Map.Map Var (WithTop Lit)
21 constLattice :: DataflowLattice ConstFact
22 constLattice = DataflowLattice
23 { fact_name = "Const var value"
24 , fact_bot = Map.empty
25 , fact_extend = stdMapJoin (joinWithTop' constFactAdd)
26 , fact_do_logging = False }
27 where
28 constFactAdd _ (OldFact old) (NewFact new)
29 = (changeIf (new /= old), joined)
30 where joined = if new == old then PElem new else Top
31
32 -- @ end cprop.tex
33 -- Initially, we assume that all variable values are unknown.
34 initFact :: [Var] -> ConstFact
35 initFact vars = M.fromList $ [(v, Top) | v <- vars]
36
37 -- Only interesting semantic choice: values of variables are live across
38 -- a call site.
39 -- Note that we don't need a case for x := y, where y holds a constant.
40 -- We can write the simplest solution and rely on the interleaved optimization.
41 -- @ start cprop.tex
42 --------------------------------------------------
43 -- Analysis: variable equals a literal constant
44 varHasLit :: FwdTransfer Node ConstFact
45 varHasLit = mkFTransfer lt
46 where
47 lt :: Node e x -> ConstFact -> Fact x ConstFact
48 lt (Label _) f = f
49 lt (Assign x (Lit v)) f = M.insert x (PElem v) f
50 lt (Assign x _) f = M.insert x Top f
51 lt (Store _ _) f = f
52 lt (Branch l) f = mkFactBase [(l, f)]
53 lt (Cond (Var x) tl fl) f
54 = mkFactBase [(tl, Map.insert x (b True) f),
55 (fl, Map.insert x (b False) f)]
56 where b = PElem . Bool
57 lt (Cond _ tl fl) f = mkFactBase [(tl, f), (fl, f)]
58
59 -- @ end cprop.tex
60 lt (Call vs _ _ bid) f = mkFactBase [(bid, foldl toTop f vs)]
61 where toTop f v = M.insert v Top f
62 lt (Return _) _ = mkFactBase []
63
64 -- @ start cprop.tex
65 --------------------------------------------------
66 -- Rewriting: propagate and fold constants
67 constProp :: Monad m => FwdRewrite m Node ConstFact
68 constProp = shallowFwdRw cp
69 where
70 cp node f
71 = return $ fmap insnToG $ mapVN (lookup f) node
72 lookup f x
73 = case M.lookup x f of
74 Just (PElem v) -> Just $ Lit v
75 _ -> Nothing
76 -- @ end cprop.tex
77 mapVN = map_VN