Constant-propagation figure is now extracted automatically from John's code; some...
authorNorman Ramsey <nr@cs.tufts.edu>
Wed, 12 May 2010 19:00:00 +0000 (15:00 -0400)
committerNorman Ramsey <nr@cs.tufts.edu>
Wed, 12 May 2010 19:00:00 +0000 (15:00 -0400)
In particular

  suffix '3' for functions expecting or working with a triple
  no suffix for function expecting or working with higher-rank
     polymorphism (which is now explained in the paper as
     the default interface for clients).

15 files changed:
paper/.gitignore
paper/dfopt.tex
paper/mkfile
paper/xsource [new file with mode: 0755]
src/Compiler/Hoopl/Combinators.hs
src/Compiler/Hoopl/Dataflow.hs
src/Compiler/Hoopl/Debug.hs
src/Compiler/Hoopl/Passes/DList.hs
src/Compiler/Hoopl/Passes/Dominator.hs
src/hoopl.cabal
testing/ConstProp.hs
testing/Live.hs
testing/OptSupport.hs
testing/Simplify.hs
testing/Test.hs

index 4a8780f..5f3e6f8 100644 (file)
@@ -15,6 +15,7 @@ notesinmargin.tex
 
 
 timestamp.tex
+cprop.tex
 hoopl.tex
 hoopl.ps
 
index 1bff1fb..01eb8d3 100644 (file)
@@ -1296,6 +1296,8 @@ the result is the same as the first argument (the old fact), and
 (Function @fact_extend@ is \emph{not} symmetric in
 its arguments.)
 
+\remark{Notes about @changeIf@, @PElem@, @WithTop@?}
+
 % A~possible representation of the facts needed to implement
 % constant propagation is shown in \figref{const-prop}.
 % A~fact
@@ -1624,75 +1626,84 @@ yielding better results than running $A$~and then~$B$ or $B$~and then~$A$
 % omit Add :: Operator
 
 
+%%  \begin{figure}
+%%  {\small\hfuzz=3pt
+%%  \begin{code}
+%%  -- Types and definition of the lattice
+%%  data `HasConst = `Top | `B Bool | `I Integer
+%%  type `ConstFact = Map.Map Var HasConst
+%%  `constLattice = DataflowLattice
+%%    { fact_bot    = Map.empty
+%%    , fact_extend = stdMapJoin constFactAdd }
+%%    where
+%%      `constFactAdd ^old ^new = (c, j)
+%%        where j = if new == old then new else Top
+%%              c = if j == old then NoChange else SomeChange
+%%  
+%%  -------------------------------------------------------
+%%  -- Analysis: variable has constant value
+%%  `varHasConst :: FwdTransfer Node ConstFact
+%%  varHasConst (Label l)       f = lookupFact f l
+%%  varHasConst (Store _ _)         f = f
+%%  varHasConst (Assign x (Bool b)) f = Map.insert x (B b) f
+%%  varHasConst (Assign x (Int  i)) f = Map.insert x (I i) f
+%%  varHasConst (Assign x _)        f = Map.insert x Top   f
+%%  varHasConst (Branch l)          f = mkFactBase [(l, f)]
+%%  varHasConst (CondBranch (Var x) ^tid ^fid) f
+%%    = mkFactBase [(tid, Map.insert x (B True)  f),
+%%                  (fid, Map.insert x (B False) f)]
+%%  varHasConst (CondBranch _ tid fid) f 
+%%    = mkFactBase [(tid, f), (fid, f)]
+%%  
+%%  -------------------------------------------------------
+%%  -- Constant propagation
+%%  `constProp :: FwdRewrite Node ConstFact
+%%  constProp node ^facts
+%%    = fmap toAGraph (mapE rewriteE node)
+%%    where
+%%      `rewriteE e (Var x)
+%%        = case Map.lookup x facts of
+%%            Just (B b) -> Just $ Bool b
+%%            Just (I i) -> Just $ Int  i
+%%            _          -> Nothing
+%%      rewriteE e = Nothing
+%%  
+%%  -------------------------------------------------------
+%%  -- Simplification ("constant folding")
+%%  `simplify :: FwdRewrite Node f
+%%  simplify (CondBranch (Bool b) t f) _
+%%    = Just $ toAGraph $ Branch (if b then t else f)
+%%  simplify node _ = fmap toAGraph (mapE s_exp node)
+%%    where
+%%      `s_exp (Binop Add (Int i1) (Int i2))
+%%         = Just $ Int $ i1 + i2
+%%      ...  -- more cases for constant folding
+%%  
+%%  -- Rewriting expressions
+%%  `mapE :: (Expr    -> Maybe Expr) 
+%%        -> Node e x -> Maybe (Node e x)
+%%  mapE f (Label _) = Nothing
+%%  mapE f (Assign x e)  = fmap (Assign x) $ f e
+%%   ...  -- more cases for rewriting expressions
+%%  
+%%  -------------------------------------------------------
+%%  -- Defining the forward dataflow pass
+%%  `constPropPass = FwdPass
+%%     { fp_lattice  = constLattice
+%%     , fp_transfer = varHasConst
+%%     , fp_rewrite  = constProp `thenFwdRw` simplify } 
+%%  \end{code}}
+%%  \caption{The client for constant propagation and constant folding} \figlabel{old-const-prop}
+%%  \end{figure}
 \begin{figure}
-{\small\hfuzz=3pt
-\begin{code}
--- Types and definition of the lattice
-data `HasConst = `Top | `B Bool | `I Integer
-type `ConstFact = Map.Map Var HasConst
-`constLattice = DataflowLattice
-  { fact_bot    = Map.empty
-  , fact_extend = stdMapJoin constFactAdd }
-  where
-    `constFactAdd ^old ^new = (c, j)
-      where j = if new == old then new else Top
-            c = if j == old then NoChange else SomeChange
-
--------------------------------------------------------
--- Analysis: variable has constant value
-`varHasConst :: FwdTransfer Node ConstFact
-varHasConst (Label l)       f = lookupFact f l
-varHasConst (Store _ _)         f = f
-varHasConst (Assign x (Bool b)) f = Map.insert x (B b) f
-varHasConst (Assign x (Int  i)) f = Map.insert x (I i) f
-varHasConst (Assign x _)        f = Map.insert x Top   f
-varHasConst (Branch l)          f = mkFactBase [(l, f)]
-varHasConst (CondBranch (Var x) ^tid ^fid) f
-  = mkFactBase [(tid, Map.insert x (B True)  f),
-                (fid, Map.insert x (B False) f)]
-varHasConst (CondBranch _ tid fid) f 
-  = mkFactBase [(tid, f), (fid, f)]
-
--------------------------------------------------------
--- Constant propagation
-`constProp :: FwdRewrite Node ConstFact
-constProp node ^facts
-  = fmap toAGraph (mapE rewriteE node)
-  where
-    `rewriteE e (Var x)
-      = case Map.lookup x facts of
-          Just (B b) -> Just $ Bool b
-          Just (I i) -> Just $ Int  i
-          _          -> Nothing
-    rewriteE e = Nothing
-
--------------------------------------------------------
--- Simplification ("constant folding")
-`simplify :: FwdRewrite Node f
-simplify (CondBranch (Bool b) t f) _
-  = Just $ toAGraph $ Branch (if b then t else f)
-simplify node _ = fmap toAGraph (mapE s_exp node)
-  where
-    `s_exp (Binop Add (Int i1) (Int i2))
-       = Just $ Int $ i1 + i2
-    ...  -- more cases for constant folding
-
--- Rewriting expressions
-`mapE :: (Expr    -> Maybe Expr) 
-      -> Node e x -> Maybe (Node e x)
-mapE f (Label _) = Nothing
-mapE f (Assign x e)  = fmap (Assign x) $ f e
- ...  -- more cases for rewriting expressions
-
--------------------------------------------------------
--- Defining the forward dataflow pass
-`constPropPass = FwdPass
-   { fp_lattice  = constLattice
-   , fp_transfer = varHasConst
-   , fp_rewrite  = constProp `thenFwdRw` simplify } 
-\end{code}}
-\caption{The client for constant propagation and constant folding} \figlabel{const-prop}
+{\small
+\verbatiminput{cprop}
+}
+\caption{The client for constant propagation and constant folding\break (extracted automatically from code distributed with Hoopl)}
+\figlabel{const-prop}
 \end{figure}
+
+
 \figref{const-prop} shows client code for
 constant propagation and constant folding.
 For each variable at each point in a graph, the analysis concludes one of three facts:
index b59ba27..f92645c 100644 (file)
@@ -21,7 +21,7 @@ tag:VQ: $TGT.tex
        echo git tag $tag
        git tag $tag
 
-dfopt.dvi: dfopt.bbl code.sty timestamp.tex dfoptdu.tex
+dfopt.dvi: dfopt.bbl code.sty timestamp.tex dfoptdu.tex cprop.tex
 
 $TGT.pdf: $TGT.dvi
        dvips -Ppdf -o"|ps2pdf - $target" -pp 1-$LASTPAGE $prereq
@@ -50,3 +50,9 @@ timestamp.tex: $TGT.tex
        ./defuse < $stem.tex > $target
        chmod -w $target
 
+
+CLIENT=../testing
+CPROPS=ConstProp Simplify Test
+
+cprop.tex:D: ./xsource ${CPROPS:%=$CLIENT/%.hs}
+       lua $prereq > $target
diff --git a/paper/xsource b/paper/xsource
new file mode 100755 (executable)
index 0000000..3edb514
--- /dev/null
@@ -0,0 +1,47 @@
+#!/usr/bin/env lua
+
+local outputs = { } -- map filename to list of lines
+setmetatable(outputs, { __index = function(t, k) local u = {}; t[k] = u; return u end })
+
+local function add_modified_line(lines, l)
+  if l:find '%{ fact_name%s+=' then
+    return
+  elseif l:find '%, fact_do_logging%s+=' then
+    return
+  end
+  l = l:gsub('^(%s*),( fact_bot)', '%1{%2')
+  l = l:gsub('^(%s*, fact_extend = .*)$', '%1 }')
+  return table.insert(lines, l)
+end
+
+
+for _, file in ipairs(arg) do
+  local outfile
+  for l in io.lines(file) do
+    local action, filename = l:match '^%s*%-%-%s%@%s+(%w+)%s+(%S+)%s*$'
+    if action == 'start' then
+      assert(outfile == nil)
+      outfile = filename
+    elseif action == 'stop' or action == 'end' then
+      assert(outfile == filename)
+      outfile = nil
+    elseif action ~= nil then
+      error("Unknown action '" .. action .. "' in line " .. l)
+    else
+      if outfile then
+        add_modified_line(outputs[outfile], l)
+      end
+    end
+  end
+end
+
+for file, lines in pairs(outputs) do
+  local f = assert(io.open(file, 'w'))
+  for _, l in ipairs(lines) do
+    f:write(l, '\n')
+  end
+  f:close()
+end
+
+      
+      
\ No newline at end of file
index d60dd7b..8707be6 100644 (file)
@@ -1,10 +1,10 @@
 {-# LANGUAGE RankNTypes, LiberalTypeSynonyms, ScopedTypeVariables #-}
 
 module Compiler.Hoopl.Combinators
-  ( SimpleFwdRewrite, SimpleFwdRewrite', noFwdRewrite, thenFwdRw
-  , shallowFwdRw3, shallowFwdRwPoly, deepFwdRw3, deepFwdRwPoly, iterFwdRw
-  , SimpleBwdRewrite, SimpleBwdRewrite', noBwdRewrite, thenBwdRw
-  , shallowBwdRw, shallowBwdRw', deepBwdRw, deepBwdRw', iterBwdRw
+  ( SimpleFwdRewrite, SimpleFwdRewrite3, noFwdRewrite, thenFwdRw
+  , shallowFwdRw3, shallowFwdRw, deepFwdRw3, deepFwdRw, iterFwdRw
+  , SimpleBwdRewrite, SimpleBwdRewrite3, noBwdRewrite, thenBwdRw
+  , shallowBwdRw3, shallowBwdRw, deepBwdRw3, deepBwdRw, iterBwdRw
   , productFwd, productBwd
   )
 
@@ -24,9 +24,9 @@ type BR m n f = BwdRewrite m n f
 
 type SFRW m n f e x = n e x -> f -> m (Maybe (Graph n e x))
 type FRW  m n f e x = n e x -> f -> m (FwdRes m n f e x)
-type SimpleFwdRewrite  m n f = ExTriple (SFRW m n f)
+type SimpleFwdRewrite3 m n f = ExTriple (SFRW m n f)
 type ExTriple a = (a C O, a O O, a O C) -- ^ entry/exit triple
-type SimpleFwdRewrite' m n f = forall e x . SFRW m n f e x
+type SimpleFwdRewrite m n f = forall e x . SFRW m n f e x
 type LiftFRW m n f e x = SFRW m n f e x -> FRW m n f e x
 type MapFRW  m n f e x = FRW  m n f e x -> FRW m n f e x
 type MapFRW2 m n f e x = FRW  m n f e x -> FRW m n f e x -> FRW m n f e x
@@ -47,23 +47,23 @@ applyBinary (f1, f2, f3) (x1, x2, x3) (y1, y2, y3) = (f1 x1 y1, f2 x2 y2, f3 x3
 
 ----------------------------------------------------------------
 
-wrapSFRewrites :: ExTriple (LiftFRW m n f) -> SimpleFwdRewrite m n f -> FR m n f
-wrapSFRewrites lift rw = uncurry3 mkFRewrite $ apply lift rw
+wrapSFRewrite3 :: ExTriple (LiftFRW m n f) -> SimpleFwdRewrite3 m n f -> FR m n f
+wrapSFRewrite3 lift rw = uncurry3 mkFRewrite3 $ apply lift rw
 
-wrapFRewrites :: ExTriple (MapFRW m n f) -> FR m n f -> FR m n f
-wrapFRewrites map frw = uncurry3 mkFRewrite $ apply map $ getFRewrites frw
+wrapFRewrite3 :: ExTriple (MapFRW m n f) -> FR m n f -> FR m n f
+wrapFRewrite3 map frw = uncurry3 mkFRewrite3 $ apply map $ getFRewrite3 frw
 
 wrapFRewrites2 :: ExTriple (MapFRW2 m n f) -> FR m n f -> FR m n f -> FR m n f
 wrapFRewrites2 map frw1 frw2 =
-  uncurry3 mkFRewrite $ (applyBinary map `on` getFRewrites) frw1 frw2
+  uncurry3 mkFRewrite3 $ (applyBinary map `on` getFRewrite3) frw1 frw2
 
 
 -- Combinators for higher-rank rewriting functions:
-wrapSFRewrites' :: (forall e x . LiftFRW m n f e x) -> SimpleFwdRewrite m n f -> FR m n f
-wrapSFRewrites' lift = wrapSFRewrites (lift, lift, lift)
+wrapSFRewrites' :: (forall e x . LiftFRW m n f e x) -> SimpleFwdRewrite3 m n f -> FR m n f
+wrapSFRewrites' lift = wrapSFRewrite3 (lift, lift, lift)
 
 wrapFRewrites' :: (forall e x . MapFRW m n f e x) -> FR m n f -> FR m n f
-wrapFRewrites' map = wrapFRewrites (map, map, map)
+wrapFRewrites' map = wrapFRewrite3 (map, map, map)
 -- It's ugly that we can't use
 --    wrapFRewrites' = mkFRewrite'
 -- Would be nice to refactor here XXX  ---NR
@@ -75,21 +75,21 @@ wrapFRewrites2' map = wrapFRewrites2 (map, map, map)
 ----------------------------------------------------------------
 
 noFwdRewrite :: Monad m => FwdRewrite m n f
-noFwdRewrite = mkFRewrite' $ \ _ _ -> return NoFwdRes
+noFwdRewrite = mkFRewrite $ \ _ _ -> return NoFwdRes
 
-shallowFwdRw3 :: forall m n f . Monad m => SimpleFwdRewrite m n f -> FwdRewrite m n f
+shallowFwdRw3 :: forall m n f . Monad m => SimpleFwdRewrite3 m n f -> FwdRewrite m n f
 shallowFwdRw3 rw = wrapSFRewrites' lift rw
   where lift rw n f = liftM withoutRewrite (rw n f) 
         withoutRewrite Nothing = NoFwdRes
         withoutRewrite (Just g) = FwdRes g noFwdRewrite
 
-shallowFwdRwPoly :: Monad m => SimpleFwdRewrite' m n f -> FwdRewrite m n f
-shallowFwdRwPoly f = shallowFwdRw3 (f, f, f)
+shallowFwdRw :: Monad m => SimpleFwdRewrite m n f -> FwdRewrite m n f
+shallowFwdRw f = shallowFwdRw3 (f, f, f)
 
-deepFwdRw3    :: Monad m => SimpleFwdRewrite  m n f -> FwdRewrite m n f
-deepFwdRwPoly :: Monad m => SimpleFwdRewrite' m n f -> FwdRewrite m n f
+deepFwdRw3    :: Monad m => SimpleFwdRewrite3 m n f -> FwdRewrite m n f
+deepFwdRw :: Monad m => SimpleFwdRewrite m n f -> FwdRewrite m n f
 deepFwdRw3    r = iterFwdRw (shallowFwdRw3 r)
-deepFwdRwPoly f = deepFwdRw3 (f, f, f)
+deepFwdRw f = deepFwdRw3 (f, f, f)
 
 thenFwdRw :: Monad m => FwdRewrite m n f -> FwdRewrite m n f -> FwdRewrite m n f
 thenFwdRw rw1 rw2 = wrapFRewrites2' tfr rw1 rw2
@@ -109,30 +109,30 @@ iterFwdRw rw = wrapFRewrites' f rw
 
 type SBRW m n f e x = n e x -> Fact x f -> m (Maybe (Graph n e x))
 type BRW  m n f e x = n e x -> Fact x f -> m (BwdRes m n f e x)
-type SimpleBwdRewrite  m n f = ExTriple ( SBRW m n f)
-type SimpleBwdRewrite' m n f = forall e x . SBRW m n f e x
+type SimpleBwdRewrite3 m n f = ExTriple ( SBRW m n f)
+type SimpleBwdRewrite m n f = forall e x . SBRW m n f e x
 type LiftBRW m n f e x = SBRW m n f e x -> BRW m n f e x
 type MapBRW  m n f e x = BRW  m n f e x -> BRW m n f e x
 type MapBRW2 m n f e x = BRW  m n f e x -> BRW m n f e x -> BRW m n f e x
 
 ----------------------------------------------------------------
 
-wrapSBRewrites :: ExTriple (LiftBRW m n f) -> SimpleBwdRewrite m n f -> BwdRewrite m n f
-wrapSBRewrites lift rw = uncurry3 mkBRewrite $ apply lift rw
+wrapSBRewrite3 :: ExTriple (LiftBRW m n f) -> SimpleBwdRewrite3 m n f -> BwdRewrite m n f
+wrapSBRewrite3 lift rw = uncurry3 mkBRewrite3 $ apply lift rw
 
-wrapBRewrites :: ExTriple (MapBRW m n f) -> BwdRewrite m n f -> BwdRewrite m n f
-wrapBRewrites map rw = uncurry3 mkBRewrite $ apply map $ getBRewrites rw
+wrapBRewrite3 :: ExTriple (MapBRW m n f) -> BwdRewrite m n f -> BwdRewrite m n f
+wrapBRewrite3 map rw = uncurry3 mkBRewrite3 $ apply map $ getBRewrite3 rw
 
 wrapBRewrites2 :: ExTriple (MapBRW2 m n f) -> BR m n f -> BR m n f -> BR m n f
 wrapBRewrites2 map rw1 rw2 =
-  uncurry3 mkBRewrite $ (applyBinary map `on` getBRewrites) rw1 rw2
+  uncurry3 mkBRewrite3 $ (applyBinary map `on` getBRewrite3) rw1 rw2
 
 -- Combinators for higher-rank rewriting functions:
-wrapSBRewrites' :: (forall e x . LiftBRW m n f e x) -> SimpleBwdRewrite m n f -> BR m n f
-wrapSBRewrites' lift = wrapSBRewrites (lift, lift, lift)
+wrapSBRewrites' :: (forall e x . LiftBRW m n f e x) -> SimpleBwdRewrite3 m n f -> BR m n f
+wrapSBRewrites' lift = wrapSBRewrite3 (lift, lift, lift)
 
 wrapBRewrites' :: (forall e x . MapBRW m n f e x) -> BwdRewrite m n f -> BwdRewrite m n f
-wrapBRewrites' map = wrapBRewrites (map, map, map)
+wrapBRewrites' map = wrapBRewrite3 (map, map, map)
 
 wrapBRewrites2' :: (forall e x . MapBRW2 m n f e x) -> BR m n f -> BR m n f -> BR m n f
 wrapBRewrites2' map = wrapBRewrites2 (map, map, map)
@@ -140,21 +140,21 @@ wrapBRewrites2' map = wrapBRewrites2 (map, map, map)
 ----------------------------------------------------------------
 
 noBwdRewrite :: Monad m => BwdRewrite m n f
-noBwdRewrite = mkBRewrite' $ \ _ _ -> return NoBwdRes
+noBwdRewrite = mkBRewrite $ \ _ _ -> return NoBwdRes
 
-shallowBwdRw :: Monad m => SimpleBwdRewrite m n f -> BwdRewrite m n f
-shallowBwdRw rw = wrapSBRewrites' lift rw
+shallowBwdRw3 :: Monad m => SimpleBwdRewrite3 m n f -> BwdRewrite m n f
+shallowBwdRw3 rw = wrapSBRewrites' lift rw
   where lift rw n f = liftM withoutRewrite (rw n f)
         withoutRewrite Nothing = NoBwdRes
         withoutRewrite (Just g) = BwdRes g noBwdRewrite
 
-shallowBwdRw' :: Monad m => SimpleBwdRewrite' m n f -> BwdRewrite m n f
-shallowBwdRw' f = shallowBwdRw (f, f, f)
+shallowBwdRw :: Monad m => SimpleBwdRewrite m n f -> BwdRewrite m n f
+shallowBwdRw f = shallowBwdRw3 (f, f, f)
 
+deepBwdRw3 :: Monad m => SimpleBwdRewrite3 m n f -> BwdRewrite m n f
 deepBwdRw  :: Monad m => SimpleBwdRewrite  m n f -> BwdRewrite m n f
-deepBwdRw' :: Monad m => SimpleBwdRewrite' m n f -> BwdRewrite m n f
-deepBwdRw  r = iterBwdRw (shallowBwdRw r)
-deepBwdRw' f = deepBwdRw (f, f, f)
+deepBwdRw3 r = iterBwdRw (shallowBwdRw3 r)
+deepBwdRw  f = deepBwdRw3 (f, f, f)
 
 
 thenBwdRw :: Monad m => BwdRewrite m n f -> BwdRewrite m n f -> BwdRewrite m n f
@@ -175,7 +175,7 @@ productFwd :: forall m n f f' . Monad m => FwdPass m n f -> FwdPass m n f' -> Fw
 productFwd pass1 pass2 = FwdPass lattice transfer rewrite
   where
     lattice = productLattice (fp_lattice pass1) (fp_lattice pass2)
-    transfer = mkFTransfer (tf tf1 tf2) (tf tm1 tm2) (tfb tl1 tl2)
+    transfer = mkFTransfer3 (tf tf1 tf2) (tf tm1 tm2) (tfb tl1 tl2)
       where
         tf  t1 t2 n (f1, f2) = (t1 n f1, t2 n f2)
         tfb t1 t2 n (f1, f2) = mapMapWithKey withfb2 fb1
@@ -183,34 +183,34 @@ productFwd pass1 pass2 = FwdPass lattice transfer rewrite
                 fb2 = t2 n f2
                 withfb2 l f = (f, fromMaybe bot2 $ lookupFact l fb2)
                 bot2 = fact_bot (fp_lattice pass2)
-        (tf1, tm1, tl1) = getFTransfers (fp_transfer pass1)
-        (tf2, tm2, tl2) = getFTransfers (fp_transfer pass2)
+        (tf1, tm1, tl1) = getFTransfer3 (fp_transfer pass1)
+        (tf2, tm2, tl2) = getFTransfer3 (fp_transfer pass2)
     rewrite = liftRW (fp_rewrite pass1) fst `thenFwdRw` liftRW (fp_rewrite pass2) snd
       where
-        liftRW rws proj = mkFRewrite (lift f) (lift m) (lift l)
+        liftRW rws proj = mkFRewrite3 (lift f) (lift m) (lift l)
           where lift rw n f = liftM projRewrite $ rw n (proj f)
                 projRewrite NoFwdRes = NoFwdRes
                 projRewrite (FwdRes g rws') = FwdRes g $ liftRW rws' proj
-                (f, m, l) = getFRewrites rws
+                (f, m, l) = getFRewrite3 rws
 
 productBwd :: forall m n f f' . Monad m => BwdPass m n f -> BwdPass m n f' -> BwdPass m n (f, f')
 productBwd pass1 pass2 = BwdPass lattice transfer rewrite
   where
     lattice = productLattice (bp_lattice pass1) (bp_lattice pass2)
-    transfer = mkBTransfer (tf tf1 tf2) (tf tm1 tm2) (tfb tl1 tl2)
+    transfer = mkBTransfer3 (tf tf1 tf2) (tf tm1 tm2) (tfb tl1 tl2)
       where
         tf  t1 t2 n (f1, f2) = (t1 n f1, t2 n f2)
         tfb t1 t2 n fb = (t1 n $ mapMap fst fb, t2 n $ mapMap snd fb)
-        (tf1, tm1, tl1) = getBTransfers (bp_transfer pass1)
-        (tf2, tm2, tl2) = getBTransfers (bp_transfer pass2)
+        (tf1, tm1, tl1) = getBTransfer3 (bp_transfer pass1)
+        (tf2, tm2, tl2) = getBTransfer3 (bp_transfer pass2)
     rewrite = liftRW (bp_rewrite pass1) fst `thenBwdRw` liftRW (bp_rewrite pass2) snd
       where
         liftRW :: forall f1 . BwdRewrite m n f1 -> ((f, f') -> f1) -> BwdRewrite m n (f, f')
-        liftRW rws proj = mkBRewrite (lift proj f) (lift proj m) (lift (mapMap proj) l)
+        liftRW rws proj = mkBRewrite3 (lift proj f) (lift proj m) (lift (mapMap proj) l)
           where lift proj' rw n f = liftM projRewrite $ rw n (proj' f)
                 projRewrite NoBwdRes = NoBwdRes
                 projRewrite (BwdRes g rws') = BwdRes g $ liftRW rws' proj
-                (f, m, l) = getBRewrites rws
+                (f, m, l) = getBRewrite3 rws
 
 productLattice :: forall f f' . DataflowLattice f -> DataflowLattice f' -> DataflowLattice (f, f')
 productLattice l1 l2 =
index 6f12bcc..a117006 100644 (file)
@@ -3,10 +3,10 @@
 module Compiler.Hoopl.Dataflow
   ( DataflowLattice(..), JoinFun, OldFact(..), NewFact(..), Fact
   , ChangeFlag(..), changeIf
-  , FwdPass(..), FwdTransfer, mkFTransfer, mkFTransfer', getFTransfers
-  , FwdRes(..),  FwdRewrite,  mkFRewrite,  mkFRewrite',  getFRewrites
-  , BwdPass(..), BwdTransfer, mkBTransfer, mkBTransfer', getBTransfers
-  , BwdRes(..),  BwdRewrite,  mkBRewrite,  mkBRewrite',  getBRewrites
+  , FwdPass(..), FwdTransfer, mkFTransfer, mkFTransfer3, getFTransfer3
+  , FwdRes(..),  FwdRewrite,  mkFRewrite,  mkFRewrite3,  getFRewrite3
+  , BwdPass(..), BwdTransfer, mkBTransfer, mkBTransfer3, getBTransfer3
+  , BwdRes(..),  BwdRewrite,  mkBRewrite,  mkBRewrite3,  getBRewrite3
   , analyzeAndRewriteFwd,  analyzeAndRewriteBwd
   )
 where
@@ -56,14 +56,14 @@ data FwdPass m n f
             , fp_rewrite  :: FwdRewrite m n f }
 
 newtype FwdTransfer n f 
-  = FwdTransfers { getFTransfers ::
+  = FwdTransfer3 { getFTransfer3 ::
                      ( n C O -> f -> f
                      , n O O -> f -> f
                      , n O C -> f -> FactBase f
                      ) }
 
 newtype FwdRewrite m n f 
-  = FwdRewrites { getFRewrites ::
+  = FwdRewrite3 { getFRewrite3 ::
                     ( n C O -> f -> m (FwdRes m n f C O)
                     , n O O -> f -> m (FwdRes m n f O O)
                     , n O C -> f -> m (FwdRes m n f O C)
@@ -72,23 +72,23 @@ data FwdRes m n f e x = FwdRes (Graph n e x) (FwdRewrite m n f)
                       | NoFwdRes
   -- result of a rewrite is a new graph and a (possibly) new rewrite function
 
-mkFTransfer :: (n C O -> f -> f)
-            -> (n O O -> f -> f)
-            -> (n O C -> f -> FactBase f)
-            -> FwdTransfer n f
-mkFTransfer f m l = FwdTransfers (f, m, l)
+mkFTransfer3 :: (n C O -> f -> f)
+             -> (n O O -> f -> f)
+             -> (n O C -> f -> FactBase f)
+             -> FwdTransfer n f
+mkFTransfer3 f m l = FwdTransfer3 (f, m, l)
 
-mkFTransfer' :: (forall e x . n e x -> f -> Fact x f) -> FwdTransfer n f
-mkFTransfer' f = FwdTransfers (f, f, f)
+mkFTransfer :: (forall e x . n e x -> f -> Fact x f) -> FwdTransfer n f
+mkFTransfer f = FwdTransfer3 (f, f, f)
 
-mkFRewrite :: (n C O -> f -> m (FwdRes m n f C O))
-           -> (n O O -> f -> m (FwdRes m n f O O))
-           -> (n O C -> f -> m (FwdRes m n f O C))
-           -> FwdRewrite m n f
-mkFRewrite f m l = FwdRewrites (f, m, l)
+mkFRewrite3 :: (n C O -> f -> m (FwdRes m n f C O))
+            -> (n O O -> f -> m (FwdRes m n f O O))
+            -> (n O C -> f -> m (FwdRes m n f O C))
+            -> FwdRewrite m n f
+mkFRewrite3 f m l = FwdRewrite3 (f, m, l)
 
-mkFRewrite' :: (forall e x . n e x -> f -> m (FwdRes m n f e x)) -> FwdRewrite m n f
-mkFRewrite' f = FwdRewrites (f, f, f)
+mkFRewrite :: (forall e x . n e x -> f -> m (FwdRes m n f e x)) -> FwdRewrite m n f
+mkFRewrite f = FwdRewrite3 (f, f, f)
 
 
 type family   Fact x f :: *
@@ -231,13 +231,13 @@ data BwdPass m n f
             , bp_rewrite  :: BwdRewrite m n f }
 
 newtype BwdTransfer n f 
-  = BwdTransfers { getBTransfers ::
+  = BwdTransfer3 { getBTransfer3 ::
                      ( n C O -> f          -> f
                      , n O O -> f          -> f
                      , n O C -> FactBase f -> f
                      ) }
 newtype BwdRewrite m n f 
-  = BwdRewrites { getBRewrites ::
+  = BwdRewrite3 { getBRewrite3 ::
                     ( n C O -> f          -> m (BwdRes m n f C O)
                     , n O O -> f          -> m (BwdRes m n f O O)
                     , n O C -> FactBase f -> m (BwdRes m n f O C)
@@ -245,22 +245,22 @@ newtype BwdRewrite m n f
 data BwdRes m n f e x = BwdRes (Graph n e x) (BwdRewrite m n f)
                       | NoBwdRes
 
-mkBTransfer :: (n C O -> f -> f) -> (n O O -> f -> f) ->
-               (n O C -> FactBase f -> f) -> BwdTransfer n f
-mkBTransfer f m l = BwdTransfers (f, m, l)
+mkBTransfer3 :: (n C O -> f -> f) -> (n O O -> f -> f) ->
+                (n O C -> FactBase f -> f) -> BwdTransfer n f
+mkBTransfer3 f m l = BwdTransfer3 (f, m, l)
 
-mkBTransfer' :: (forall e x . n e x -> Fact x f -> f) -> BwdTransfer n f
-mkBTransfer' f = BwdTransfers (f, f, f)
+mkBTransfer :: (forall e x . n e x -> Fact x f -> f) -> BwdTransfer n f
+mkBTransfer f = BwdTransfer3 (f, f, f)
 
-mkBRewrite :: (n C O -> f          -> m (BwdRes m n f C O))
-           -> (n O O -> f          -> m (BwdRes m n f O O))
-           -> (n O C -> FactBase f -> m (BwdRes m n f O C))
-           -> BwdRewrite m n f
-mkBRewrite f m l = BwdRewrites (f, m, l)
-
-mkBRewrite' :: (forall e x . n e x -> Fact x f -> m (BwdRes m n f e x))
+mkBRewrite3 :: (n C O -> f          -> m (BwdRes m n f C O))
+            -> (n O O -> f          -> m (BwdRes m n f O O))
+            -> (n O C -> FactBase f -> m (BwdRes m n f O C))
             -> BwdRewrite m n f
-mkBRewrite' f = BwdRewrites (f, f, f)
+mkBRewrite3 f m l = BwdRewrite3 (f, m, l)
+
+mkBRewrite :: (forall e x . n e x -> Fact x f -> m (BwdRes m n f e x))
+           -> BwdRewrite m n f
+mkBRewrite f = BwdRewrite3 (f, f, f)
 
 
 -----------------------------------------------------------------------------
@@ -588,30 +588,30 @@ instance ShapeLifter C O where
   unit            = BFirst
   elift      n f  = mkFactBase [(entryLabel n, f)]
   elower lat n fb = getFact lat (entryLabel n) fb
-  ftransfer (FwdPass {fp_transfer = FwdTransfers (ft, _, _)}) n f = ft n f
-  btransfer (BwdPass {bp_transfer = BwdTransfers (bt, _, _)}) n f = bt n f
-  frewrite  (FwdPass {fp_rewrite  = FwdRewrites  (fr, _, _)}) n f = fr n f
-  brewrite  (BwdPass {bp_rewrite  = BwdRewrites  (br, _, _)}) n f = br n f
+  ftransfer (FwdPass {fp_transfer = FwdTransfer3 (ft, _, _)}) n f = ft n f
+  btransfer (BwdPass {bp_transfer = BwdTransfer3 (bt, _, _)}) n f = bt n f
+  frewrite  (FwdPass {fp_rewrite  = FwdRewrite3  (fr, _, _)}) n f = fr n f
+  brewrite  (BwdPass {bp_rewrite  = BwdRewrite3  (br, _, _)}) n f = br n f
   entry n = JustC [entryLabel n]
 
 instance ShapeLifter O O where
   unit         = BMiddle
   elift    _ f = f
   elower _ _ f = f
-  ftransfer (FwdPass {fp_transfer = FwdTransfers (_, ft, _)}) n f = ft n f
-  btransfer (BwdPass {bp_transfer = BwdTransfers (_, bt, _)}) n f = bt n f
-  frewrite  (FwdPass {fp_rewrite  = FwdRewrites  (_, fr, _)}) n f = fr n f
-  brewrite  (BwdPass {bp_rewrite  = BwdRewrites  (_, br, _)}) n f = br n f
+  ftransfer (FwdPass {fp_transfer = FwdTransfer3 (_, ft, _)}) n f = ft n f
+  btransfer (BwdPass {bp_transfer = BwdTransfer3 (_, bt, _)}) n f = bt n f
+  frewrite  (FwdPass {fp_rewrite  = FwdRewrite3  (_, fr, _)}) n f = fr n f
+  brewrite  (BwdPass {bp_rewrite  = BwdRewrite3  (_, br, _)}) n f = br n f
   entry _ = NothingC
 
 instance ShapeLifter O C where
   unit         = BLast
   elift    _ f = f
   elower _ _ f = f
-  ftransfer (FwdPass {fp_transfer = FwdTransfers (_, _, ft)}) n f = ft n f
-  btransfer (BwdPass {bp_transfer = BwdTransfers (_, _, bt)}) n f = bt n f
-  frewrite  (FwdPass {fp_rewrite  = FwdRewrites  (_, _, fr)}) n f = fr n f
-  brewrite  (BwdPass {bp_rewrite  = BwdRewrites  (_, _, br)}) n f = br n f
+  ftransfer (FwdPass {fp_transfer = FwdTransfer3 (_, _, ft)}) n f = ft n f
+  btransfer (BwdPass {bp_transfer = BwdTransfer3 (_, _, bt)}) n f = bt n f
+  frewrite  (FwdPass {fp_rewrite  = FwdRewrite3  (_, _, fr)}) n f = fr n f
+  brewrite  (BwdPass {bp_rewrite  = BwdRewrite3  (_, _, br)}) n f = br n f
   entry _ = NothingC
 
 -- Fact lookup: the fact `orelse` bottom
index 6575825..d03320e 100644 (file)
@@ -73,8 +73,8 @@ debugFwdTransfers::
   forall m n f . Show f => TraceFn -> ShowN n -> FPred n f -> FwdPass m n f -> FwdPass m n f
 debugFwdTransfers trace showN showPred pass = pass { fp_transfer = transfers' }
   where
-    (f, m, l) = getFTransfers $ fp_transfer pass
-    transfers' = mkFTransfer (wrap show f) (wrap show m) (wrap showFactBase l)
+    (f, m, l) = getFTransfer3 $ fp_transfer pass
+    transfers' = mkFTransfer3 (wrap show f) (wrap show m) (wrap showFactBase l)
     wrap :: forall e x . (Fact x f -> String) -> (n e x -> f -> Fact x f) -> n e x -> f -> Fact x f
     wrap showOutF ft n f = if showPred n f then trace output res else res
       where
@@ -86,8 +86,8 @@ debugBwdTransfers::
   forall m n f . Show f => TraceFn -> ShowN n -> BPred n f -> BwdPass m n f -> BwdPass m n f
 debugBwdTransfers trace showN showPred pass = pass { bp_transfer = transfers' }
   where
-    (f, m, l) = getBTransfers $ bp_transfer pass
-    transfers' = mkBTransfer (wrap show f) (wrap show m) (wrap showFactBase l)
+    (f, m, l) = getBTransfer3 $ bp_transfer pass
+    transfers' = mkBTransfer3 (wrap show f) (wrap show m) (wrap showFactBase l)
     wrap :: forall e x . (Fact x f -> String) -> (n e x -> Fact x f -> f) -> n e x -> Fact x f -> f
     wrap showInF ft n f = if showPred n f then trace output res else res
       where
index 36900ef..e22a5c5 100644 (file)
@@ -41,5 +41,5 @@ extend _ (OldFact l) (NewFact l') = (changeIf (l `lengthDiffers` j), j)
 
 -- | Dominator pass
 domPass :: (Edges n, Monad m) => FwdPass m n Doms
-domPass = FwdPass domLattice (mkFTransfer first (const id) distributeFact) noFwdRewrite
+domPass = FwdPass domLattice (mkFTransfer3 first (const id) distributeFact) noFwdRewrite
   where first n = fmap (entryLabel n:)
index b793096..e73d566 100644 (file)
@@ -63,7 +63,7 @@ extend _ (OldFact (DPath l)) (NewFact (DPath l')) =
 
 -- | Dominator pass
 domPass :: (Edges n, Monad m) => FwdPass m n Doms
-domPass = FwdPass domLattice (mkFTransfer first (const id) distributeFact) noFwdRewrite
+domPass = FwdPass domLattice (mkFTransfer3 first (const id) distributeFact) noFwdRewrite
   where first n = fmap (extendDom $ entryLabel n)
 
 ----------------------------------------------------------------
index bca8fbb..0585090 100644 (file)
@@ -1,5 +1,5 @@
 Name:                hoopl
-Version:             3.8.1.0
+Version:             3.8.2.0
 Description:         Higher-order optimization library
 License:             BSD3
 License-file:        LICENSE
index ae3b0e9..e77497f 100644 (file)
@@ -9,6 +9,8 @@ import Compiler.Hoopl
 import IR
 import OptSupport
 
+type Node = Insn -- for paper
+
 -- ConstFact:
 --   Not present in map => bottom
 --   PElem v => variable has value v
@@ -21,8 +23,7 @@ constLattice = DataflowLattice
   { fact_name   = "Const var value"
   , fact_bot    = Map.empty
   , fact_extend = stdMapJoin (joinWithTop' constFactAdd)
-  , fact_do_logging = False
-  }
+  , fact_do_logging = False }
   where
     constFactAdd _ (OldFact old) (NewFact new) 
         = (changeIf (new /= old), joined)
@@ -38,36 +39,39 @@ initFact vars = M.fromList $ [(v, Top) | v <- vars]
 -- 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.
 -- @ start cprop.tex
-----------------------------------------------------------------
+--------------------------------------------------
 -- Analysis: variable equals a literal constant
-varHasLit :: FwdTransfer Insn ConstFact
-varHasLit = mkFTransfer' v
 where
-    v :: Insn e x -> ConstFact -> Fact x ConstFact
-    v (Label _)              f = f
-    v (Assign x (Lit l))     f = M.insert x (PElem l) f
-    v (Assign x _)           f = M.insert x Top f
-    v (Store _ _)            f = f
-    v (Branch bid)           f = mkFactBase [(bid, f)]
-    v (Cond (Var x) tid fid) f 
-      = mkFactBase [(tid, Map.insert x (b True)  f),
-                    (fid, Map.insert x (b False) f)]
+varHasLit :: FwdTransfer Node ConstFact
+varHasLit = mkFTransfer lt
+ where
+  lt :: Node e x -> ConstFact -> Fact x ConstFact
+  lt (Label _)            f = f
+  lt (Assign x (Lit v))   f = M.insert x (PElem v) f
+  lt (Assign x _)         f = M.insert x Top f
+  lt (Store _ _)          f = f
+  lt (Branch l)           f = mkFactBase [(l, f)]
+  lt (Cond (Var x) tl fl) f 
+      = mkFactBase [(tl, Map.insert x (b True)  f),
+                    (fl, Map.insert x (b False) f)]
           where b = PElem . Bool
-    v (Cond _  tid fid)      f 
-      = mkFactBase [(tid, f), (fid, f)]
+  lt (Cond _ tl fl) f = mkFactBase [(tl, f), (fl, f)]
 
 -- @ end cprop.tex
-    v (Call vs _ _ bid)      f = mkFactBase [(bid, foldl toTop f vs)]
+  lt (Call vs _ _ bid)      f = mkFactBase [(bid, foldl toTop f vs)]
       where toTop f v = M.insert v Top f
-    v (Return _)             _ = mkFactBase []
+  lt (Return _)             _ = mkFactBase []
 
 -- @ start cprop.tex
-----------------------------------------------------------------
+--------------------------------------------------
 -- Rewriting: propagate and fold constants
-constProp :: Monad m => FwdRewrite m Insn ConstFact
-constProp = shallowFwdRwPoly cp
-  where
-    cp node facts = return $ fmap insnToG $ (map_EN . map_EE . map_VE) lookup node
-      where lookup v = case M.lookup v facts of
-                               Just (PElem l) -> Just $ Lit l
-                               _              -> Nothing
+constProp :: Monad m => FwdRewrite m Node ConstFact
+constProp = shallowFwdRw cp
+ where
+   cp node f
+     = return $ fmap insnToG $ mapVN (lookup f) node
+   lookup f x
+     = case M.lookup x f of
+         Just (PElem v) -> Just $ Lit v
+         _              -> Nothing
+-- @ end cprop.tex
+   mapVN = map_VN
\ No newline at end of file
index de4c7ba..b59a005 100644 (file)
@@ -23,7 +23,7 @@ liveLattice = DataflowLattice
               ch = changeIf (S.size j > S.size old)
 
 liveness :: BwdTransfer Insn Live
-liveness = mkBTransfer' live
+liveness = mkBTransfer live
   where
     live :: Insn e x -> Fact x Live -> Live
     live   (Label _)       f = f
@@ -39,9 +39,9 @@ liveness = mkBTransfer' live
     addVar s _       = s
      
 deadAsstElim :: forall m . Monad m => BwdRewrite m Insn Live
-deadAsstElim = shallowBwdRw' d
+deadAsstElim = shallowBwdRw d
   where
-    d :: SimpleBwdRewrite' m Insn Live
+    d :: SimpleBwdRewrite m Insn Live
     d (Assign x _) live = if x `S.member` live then return Nothing
                                                else return $ Just emptyGraph
     d _ _ = return Nothing
index 0008da8..e00a6a7 100644 (file)
@@ -1,5 +1,6 @@
-{-# OPTIONS_GHC -Wall -fno-warn-incomplete-patterns -XGADTs -XRankNTypes #-}
-module OptSupport (stdMapJoin, map_VE, map_EE, map_EN, fold_EE, fold_EN, insnToG) where
+{-# LANGUAGE GADTs, RankNTypes #-}
+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
+module OptSupport (stdMapJoin, map_VE, map_EE, map_EN, map_VN, fold_EE, fold_EN, insnToG) where
 
 import qualified Data.Map as M
 import Data.Maybe
@@ -34,10 +35,47 @@ map_VE :: (Var  -> Maybe Expr) -> (Expr     -> Maybe Expr)
 map_EE :: (Expr -> Maybe Expr) -> (Expr     -> Maybe Expr)
 map_EN :: (Expr -> Maybe Expr) -> (Insn e x -> Maybe (Insn e x))
 
+map_VN :: (Var  -> Maybe Expr) -> (Insn e x -> Maybe (Insn e x))
+map_VN = map_EN . map_EE . map_VE
+
 map_VE f (Var v) = f v
 map_VE _ _       = Nothing
                   
 
+data Mapped a = Old a | New a
+instance Monad Mapped where
+  return = Old
+  Old a >>= k = k a
+  New a >>= k = asNew (k a)
+    where asNew (Old a)   = New a
+          asNew m@(New _) = m
+
+makeTotal :: (a -> Maybe a) -> (a -> Mapped a)
+makeTotal f a = case f a of Just a' -> New a'
+                            Nothing -> Old a
+makeTotalDefault :: b -> (a -> Maybe b) -> (a -> Mapped b)
+makeTotalDefault b f a = case f a of Just b' -> New b'
+                                     Nothing -> Old b
+ifNew :: Mapped a -> Maybe a
+ifNew (New a) = Just a
+ifNew (Old _) = Nothing
+
+type Mapping a b = a -> Mapped b
+
+(/@/) :: Mapping b c -> Mapping a b -> Mapping a c
+f /@/ g = \x -> g x >>= f
+
+
+class HasExpressions a where
+  mapAllSubexpressions :: Mapping Expr Expr -> Mapping a a
+
+instance HasExpressions (Insn e x) where
+  mapAllSubexpressions = error "urk!" (mapVars, (/@/), makeTotal, ifNew)
+                           
+mapVars :: (Var -> Maybe Expr) -> Mapping Expr Expr
+mapVars f e@(Var x) = makeTotalDefault e f x
+mapVars _ e         = return e
+
 
 map_EE f e@(Lit _)     = f e
 map_EE f e@(Var _)     = f e
index 8cdcb70..dceb091 100644 (file)
@@ -6,30 +6,52 @@ import Compiler.Hoopl
 import IR
 import OptSupport
 
+type Node = Insn
+
+
+-- @ start cprop.tex
+
+--------------------------------------------------
 -- Simplification ("constant folding")
-simplify :: forall m a . Monad m => FwdRewrite m Insn a
-simplify = deepFwdRw' simp
-  where
-    simp insn _ = return $ s insn >>= Just . insnToG
-    s :: Insn e x -> Maybe (Insn e x)
-    s (Cond (Lit (Bool True))  t _) = Just $ Branch t
-    s (Cond (Lit (Bool False)) _ f) = Just $ Branch f
-    s n = map_EN (map_EE s_e) n
-    s_e (Binop opr e1 e2)
-      | (Just op, Lit (Int i1), Lit (Int i2)) <- (intOp opr, e1, e2) =
-          Just $ Lit $ Int  $ op i1 i2
-      | (Just op, Lit (Int i1), Lit (Int i2)) <- (cmpOp opr, e1, e2) =
-          Just $ Lit $ Bool $ op i1 i2
-    s_e _ = Nothing
-    intOp Add = Just (+)
-    intOp Sub = Just (-)
-    intOp Mul = Just (*)
-    intOp Div = Just div
-    intOp _   = Nothing
-    cmpOp Eq  = Just (==)
-    cmpOp Ne  = Just (/=)
-    cmpOp Gt  = Just (>)
-    cmpOp Lt  = Just (<)
-    cmpOp Gte = Just (>=)
-    cmpOp Lte = Just (<=)
-    cmpOp _   = Nothing
+simplify :: Monad m => FwdRewrite m Node f
+simplify = deepFwdRw simp
+ where
+  simp node _ = return $ fmap nodeToG $ s_node node
+  s_node :: Node e x -> Maybe (Node e x)
+  s_node (Cond (Lit (Bool b)) t f)
+    = Just $ Branch (if b then t else f)
+  s_node n = mapE s_exp n
+  s_exp (Binop Add (Lit (Int n1)) (Lit (Int n2)))
+    = Just $ Lit $ Int $ n1 + n2
+    -- ... more cases for constant folding
+-- @ end cprop.tex
+  s_exp (Binop opr e1 e2)
+    | (Just op, Lit (Int i1), Lit (Int i2)) <- (intOp opr, e1, e2) =
+        Just $ Lit $ Int  $ op i1 i2
+    | (Just op, Lit (Int i1), Lit (Int i2)) <- (cmpOp opr, e1, e2) =
+        Just $ Lit $ Bool $ op i1 i2
+  s_exp _ = Nothing
+  intOp Add = Just (+)
+  intOp Sub = Just (-)
+  intOp Mul = Just (*)
+  intOp Div = Just div
+  intOp _   = Nothing
+  cmpOp Eq  = Just (==)
+  cmpOp Ne  = Just (/=)
+  cmpOp Gt  = Just (>)
+  cmpOp Lt  = Just (<)
+  cmpOp Gte = Just (>=)
+  cmpOp Lte = Just (<=)
+  cmpOp _   = Nothing
+  nodeToG = insnToG
+
+-- @ start cprop.tex
+
+-- Rewriting expressions
+mapE :: (Expr     -> Maybe Expr) 
+     -> (Node e x -> Maybe (Node e x))
+mapE _ (Label _)    = Nothing
+mapE f (Assign x e) = fmap (Assign x) $ f e
+ -- ... more cases for rewriting expressions
+-- @ end cprop.tex
+mapE f n = (map_EN . map_EE) f n
index 302ce4b..8e8a16f 100644 (file)
@@ -56,11 +56,21 @@ optTest' file text =
     -- With debugging info: 
     -- fwd  = debugFwdJoins trace (const True) $ FwdPass { fp_lattice = constLattice, fp_transfer = varHasLit
     --                                      , fp_rewrite = constProp `thenFwdRw` simplify }
-    fwd  = FwdPass { fp_lattice = constLattice, fp_transfer = varHasLit
-                   , fp_rewrite = constProp `thenFwdRw` simplify }
+    fwd  = constPropPass
     bwd  = BwdPass { bp_lattice = liveLattice, bp_transfer = liveness
                    , bp_rewrite = deadAsstElim }
 
+constPropPass :: Monad m => FwdPass m Insn ConstFact
+-- @ start cprop.tex
+
+----------------------------------------
+-- Defining the forward dataflow pass
+constPropPass = FwdPass
+  { fp_lattice = constLattice
+  , fp_transfer = varHasLit
+  , fp_rewrite = constProp `thenFwdRw` simplify }
+-- @ end cprop.tex
+
 optTest :: String -> IO ()
 optTest file =
   do text    <- readFile file