Update changelog for v3.10.2.2 release
[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 Control.Monad
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_join = joinMaps (extendJoinDomain constFactAdd) }
26 where
27 constFactAdd _ (OldFact old) (NewFact new)
28 = if new == old then (NoChange, PElem new)
29 else (SomeChange, Top)
30
31 -- @ end cprop.tex
32 -- Initially, we assume that all variable values are unknown.
33 initFact :: [Var] -> ConstFact
34 initFact vars = Map.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 Node ConstFact
44 varHasLit = mkFTransfer ft
45 where
46 ft :: Node e x -> ConstFact -> Fact x ConstFact
47 ft (Label _) f = f
48 ft (Assign x (Lit k)) f = Map.insert x (PElem k) f
49 ft (Assign x _) f = Map.insert x Top f
50 ft (Store _ _) f = f
51 ft (Branch l) f = mapSingleton l f
52 ft (Cond (Var x) tl fl) f
53 = mkFactBase constLattice
54 [(tl, Map.insert x (PElem (Bool True)) f),
55 (fl, Map.insert x (PElem (Bool False)) f)]
56 ft (Cond _ tl fl) f
57 = mkFactBase constLattice [(tl, f), (fl, f)]
58
59 -- @ end cprop.tex
60 ft (Call vs _ _ bid) f = mapSingleton bid (foldl toTop f vs)
61 where toTop f v = Map.insert v Top f
62 ft (Return _) _ = mapEmpty
63
64 type MaybeChange a = a -> Maybe a
65 -- @ start cprop.tex
66 --------------------------------------------------
67 -- Rewriting: replace constant variables
68 constProp :: forall m. FuelMonad m => FwdRewrite m Node ConstFact
69 constProp = mkFRewrite cp
70 where
71 cp :: Node e x -> ConstFact -> m (Maybe (Graph Node e x))
72 cp node f
73 = return $ liftM insnToG $ mapVN (lookup f) node
74
75 mapVN :: (Var -> Maybe Expr) -> MaybeChange (Node e x)
76 mapVN = mapEN . mapEE . mapVE
77
78 lookup :: ConstFact -> Var -> Maybe Expr
79 lookup f x = case Map.lookup x f of
80 Just (PElem v) -> Just $ Lit v
81 _ -> Nothing
82 -- @ end cprop.tex