Make Hoopl work with MonoLocalBinds.
authorEdward Z. Yang <ezyang@mit.edu>
Sat, 25 Dec 2010 02:26:15 +0000 (21:26 -0500)
committerDaniel Peebles <pumpkingod@gmail.com>
Sat, 25 Dec 2010 17:49:27 +0000 (12:49 -0500)
This was achieved by adding GHC-generated type signatures wherever
polymorphism was necessary.  Some of these type signatures are quite
ugly, so someone who is more familiar with the code should specialize
them as appropriate.

src/Compiler/Hoopl/Combinators.hs
src/Compiler/Hoopl/Dataflow.hs
src/Compiler/Hoopl/Util.hs
src/Compiler/Hoopl/XUtil.hs
testing/ConstProp.hs
testing/Eval.hs
testing/Live.hs
testing/Main.hs
testing/Simplify.hs

index 4ed3845..1cdbd28 100644 (file)
@@ -34,25 +34,37 @@ deepFwdRw f = deepFwdRw3 f f f
 -- N.B. rw3, rw3', and rw3a are triples of functions.
 -- But rw and rw' are single functions.
 -- @ start comb1.tex
-thenFwdRw :: Monad m 
+thenFwdRw :: forall m n f. Monad m 
           => FwdRewrite m n f 
           -> FwdRewrite m n f 
           -> FwdRewrite m n f
 -- @ end comb1.tex
 thenFwdRw rw3 rw3' = wrapFR2 thenrw rw3 rw3'
  where
+  thenrw :: forall m1 e x t t1.
+            Monad m1 =>
+            (t -> t1 -> m1 (Maybe (Graph n e x, FwdRewrite m n f)))
+            -> (t -> t1 -> m1 (Maybe (Graph n e x, FwdRewrite m n f)))
+            -> t
+            -> t1
+            -> m1 (Maybe (Graph n e x, FwdRewrite m n f))
   thenrw rw rw' n f = rw n f >>= fwdRes
      where fwdRes Nothing   = rw' n f
            fwdRes (Just gr) = return $ Just $ fadd_rw rw3' gr
 
 -- @ start iterf.tex
-iterFwdRw :: Monad m 
+iterFwdRw :: forall m n f. Monad m 
           => FwdRewrite m n f 
           -> FwdRewrite m n f
 -- @ end iterf.tex
 iterFwdRw rw3 = wrapFR iter rw3
- where iter rw n = (liftM $ liftM $ fadd_rw (iterFwdRw rw3)) . rw n
-       _iter = frewrite_cps (return . Just . fadd_rw (iterFwdRw rw3)) (return Nothing)
+ where iter :: forall a m1 m2 e x t.
+               (Monad m2, Monad m1) =>
+               (t -> a -> m1 (m2 (Graph n e x, FwdRewrite m n f)))
+               -> t
+               -> a
+               -> m1 (m2 (Graph n e x, FwdRewrite m n f))
+       iter rw n = (liftM $ liftM $ fadd_rw (iterFwdRw rw3)) . rw n
 
 -- | Function inspired by 'rew' in the paper
 frewrite_cps :: Monad m
@@ -90,17 +102,32 @@ deepBwdRw3 f m l = iterBwdRw $ mkBRewrite3 f m l
 deepBwdRw  f = deepBwdRw3 f f f
 
 
-thenBwdRw :: Monad m => BwdRewrite m n f -> BwdRewrite m n f -> BwdRewrite m n f
+thenBwdRw :: forall m n f. Monad m => BwdRewrite m n f -> BwdRewrite m n f -> BwdRewrite m n f
 thenBwdRw rw1 rw2 = wrapBR2 f rw1 rw2
-  where f _ rw1 rw2' n f = do
+  where f :: forall t t1 t2 m1 e x.
+             Monad m1 =>
+             t
+             -> (t1 -> t2 -> m1 (Maybe (Graph n e x, BwdRewrite m n f)))
+             -> (t1 -> t2 -> m1 (Maybe (Graph n e x, BwdRewrite m n f)))
+             -> t1
+             -> t2
+             -> m1 (Maybe (Graph n e x, BwdRewrite m n f))
+        f _ rw1 rw2' n f = do
           res1 <- rw1 n f
           case res1 of
             Nothing -> rw2' n f
             Just gr -> return $ Just $ badd_rw rw2 gr
 
-iterBwdRw :: Monad m => BwdRewrite m n f -> BwdRewrite m n f
+iterBwdRw :: forall m n f. Monad m => BwdRewrite m n f -> BwdRewrite m n f
 iterBwdRw rw = wrapBR f rw
-  where f _ rw' n f = liftM (liftM (badd_rw (iterBwdRw rw))) (rw' n f)
+  where f :: forall t m1 m2 e x t1 t2.
+             (Monad m2, Monad m1) =>
+             t
+             -> (t1 -> t2 -> m1 (m2 (Graph n e x, BwdRewrite m n f)))
+             -> t1
+             -> t2
+             -> m1 (m2 (Graph n e x, BwdRewrite m n f))
+        f _ rw' n f = liftM (liftM (badd_rw (iterBwdRw rw))) (rw' n f)
 
 -- | Function inspired by 'add' in the paper
 badd_rw :: Monad m
@@ -111,7 +138,7 @@ badd_rw rw2 (g, rw1) = (g, rw1 `thenBwdRw` rw2)
 
 
 -- @ start pairf.tex
-pairFwd :: Monad m
+pairFwd :: forall m n f f'. Monad m
         => FwdPass m n f
         -> FwdPass m n f' 
         -> FwdPass m n (f, f')
@@ -121,18 +148,32 @@ pairFwd pass1 pass2 = FwdPass lattice transfer rewrite
     lattice = pairLattice (fp_lattice pass1) (fp_lattice pass2)
     transfer = mkFTransfer3 (tf tf1 tf2) (tf tm1 tm2) (tfb tl1 tl2)
       where
+        tf :: forall t t1 t2 t3 t4.
+              (t4 -> t -> t2) -> (t4 -> t1 -> t3) -> t4 -> (t, t1) -> (t2, t3)
         tf  t1 t2 n (f1, f2) = (t1 n f1, t2 n f2)
         tfb t1 t2 n (f1, f2) = mapMapWithKey withfb2 fb1
           where fb1 = t1 n f1
                 fb2 = t2 n f2
+                withfb2 :: forall t. Label -> t -> (t, f')
                 withfb2 l f = (f, fromMaybe bot2 $ lookupFact l fb2)
                 bot2 = fact_bot (fp_lattice pass2)
         (tf1, tm1, tl1) = getFTransfer3 (fp_transfer pass1)
         (tf2, tm2, tl2) = getFTransfer3 (fp_transfer pass2)
     rewrite = lift fst (fp_rewrite pass1) `thenFwdRw` lift snd (fp_rewrite pass2) 
       where
+        lift :: forall f m' n' f'.
+                Monad m' =>
+                (f' -> f) -> FwdRewrite m' n' f -> FwdRewrite m' n' f'
         lift proj = wrapFR project
-          where project rw = \n pair -> liftM (liftM repair) $ rw n (proj pair)
+          where project :: forall m m1 t t1.
+                          (Monad m1, Monad m) =>
+                          (t1 -> f -> m (m1 (t, FwdRewrite m' n' f)))
+                          -> t1
+                          -> f'
+                          -> m (m1 (t, FwdRewrite m' n' f'))
+                project rw = \n pair -> liftM (liftM repair) $ rw n (proj pair)
+                repair :: forall t.
+                          (t, FwdRewrite m' n' f) -> (t, FwdRewrite m' n' f')
                 repair (g, rw') = (g, lift proj rw')
 
 pairBwd :: forall m n f f' . 
@@ -142,7 +183,14 @@ pairBwd pass1 pass2 = BwdPass lattice transfer rewrite
     lattice = pairLattice (bp_lattice pass1) (bp_lattice pass2)
     transfer = mkBTransfer3 (tf tf1 tf2) (tf tm1 tm2) (tfb tl1 tl2)
       where
+        tf :: (t4 -> t -> t2) -> (t4 -> t1 -> t3) -> t4 -> (t, t1) -> (t2, t3)
         tf  t1 t2 n (f1, f2) = (t1 n f1, t2 n f2)
+        tfb :: IsMap map =>
+               (t2 -> map a -> t)
+               -> (t2 -> map b -> t1)
+               -> t2
+               -> map (a, b)
+               -> (t, t1)
         tfb t1 t2 n fb = (t1 n $ mapMap fst fb, t2 n $ mapMap snd fb)
         (tf1, tm1, tl1) = getBTransfer3 (bp_transfer pass1)
         (tf2, tm2, tl2) = getBTransfer3 (bp_transfer pass2)
@@ -160,6 +208,8 @@ pairBwd pass1 pass2 = BwdPass lattice transfer rewrite
                  \rw n pair -> liftM (liftM repair) $ rw n (       proj pair)
               project Closed = 
                  \rw n pair -> liftM (liftM repair) $ rw n (mapMap proj pair)
+              repair :: forall t.
+                        (t, BwdRewrite m n f1) -> (t, BwdRewrite m n (f, f'))
               repair (g, rw') = (g, lift proj rw')
                 -- XXX specialize repair so that the cost
                 -- of discriminating is one per combinator not one
index 95cfd62..f334d7a 100644 (file)
@@ -57,9 +57,10 @@ changeIf changed = if changed then SomeChange else NoChange
 -- pairs.  If the same label appears more than once, the relevant facts
 -- are joined.
 
-mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f
+mkFactBase :: forall f. DataflowLattice f -> [(Label, f)] -> FactBase f
 mkFactBase lattice = foldl add mapEmpty
-  where add map (lbl, f) = mapInsert lbl newFact map
+  where add :: FactBase f -> (Label, f) -> FactBase f
+        add map (lbl, f) = mapInsert lbl newFact map
           where newFact = case mapLookup lbl map of
                             Nothing -> f
                             Just f' -> snd $ join lbl (OldFact f') (NewFact f)
@@ -122,13 +123,15 @@ mkFTransfer f = FwdTransfer3 (f, f, f)
 
 -- | Functions passed to 'mkFRewrite3' should not be aware of the fuel supply.
 -- The result returned by 'mkFRewrite3' respects fuel.
-mkFRewrite3 :: FuelMonad m
+mkFRewrite3 :: forall m n f. FuelMonad m
             => (n C O -> f -> m (Maybe (Graph n C O)))
             -> (n O O -> f -> m (Maybe (Graph n O O)))
             -> (n O C -> f -> m (Maybe (Graph n O C)))
             -> FwdRewrite m n f
 mkFRewrite3 f m l = FwdRewrite3 (lift f, lift m, lift l)
-  where lift rw node fact = liftM (liftM asRew) (withFuel =<< rw node fact)
+  where lift :: forall t t1 a. (t -> t1 -> m (Maybe a)) -> t -> t1 -> m (Maybe (a, FwdRewrite m n f))
+        lift rw node fact = liftM (liftM asRew) (withFuel =<< rw node fact)
+        asRew :: forall t. t -> (t, FwdRewrite m n f)
         asRew g = (g, noFwdRewrite)
 
 noFwdRewrite :: Monad m => FwdRewrite m n f
@@ -275,6 +278,7 @@ arfGraph pass entries = graph
       where
         blocks  = forwardBlockList entries blockmap
         lattice = fp_lattice pass
+        do_block :: forall x. Block n C x -> FactBase f -> m (DG f n C x, Fact x f)
         do_block b fb = block b entryFact
           where entryFact = getFact lattice (entryLabel b) fb
 -- @ end bodyfun.tex
@@ -351,13 +355,15 @@ mkBTransfer f = BwdTransfer3 (f, f, f)
 
 -- | Functions passed to 'mkBRewrite3' should not be aware of the fuel supply.
 -- The result returned by 'mkBRewrite3' respects fuel.
-mkBRewrite3 :: FuelMonad m
+mkBRewrite3 :: forall m n f. FuelMonad m
             => (n C O -> f          -> m (Maybe (Graph n C O)))
             -> (n O O -> f          -> m (Maybe (Graph n O O)))
             -> (n O C -> FactBase f -> m (Maybe (Graph n O C)))
             -> BwdRewrite m n f
 mkBRewrite3 f m l = BwdRewrite3 (lift f, lift m, lift l)
-  where lift rw node fact = liftM (liftM asRew) (withFuel =<< rw node fact)
+  where lift :: forall t t1 a. (t -> t1 -> m (Maybe a)) -> t -> t1 -> m (Maybe (a, BwdRewrite m n f))
+        lift rw node fact = liftM (liftM asRew) (withFuel =<< rw node fact)
+        asRew :: t -> (t, BwdRewrite m n f)
         asRew g = (g, noBwdRewrite)
 
 noBwdRewrite :: Monad m => BwdRewrite m n f
@@ -453,6 +459,7 @@ arbGraph pass entries = graph
       = fixpoint Bwd (bp_lattice pass) do_block blocks init_fbase
       where
         blocks = backwardBlockList entries blockmap
+        do_block :: forall x. Block n C x -> Fact x f -> m (DG f n C x, LabelMap f)
         do_block b f = do (g, f) <- block b f
                           return (g, mapSingleton (entryLabel b) f)
 
@@ -558,6 +565,7 @@ fixpoint direction lat do_block blocks init_fbase
     tagged_blocks = map tag blocks
     is_fwd = case direction of { Fwd -> True; 
                                  Bwd -> False }
+    tag :: NonLocal t => t C C -> ((Label, t C C), [Label])
     tag b = ((entryLabel b, b), 
              if is_fwd then [entryLabel b] 
                         else successors b)
@@ -596,7 +604,8 @@ fixpoint direction lat do_block blocks init_fbase
     loop :: FactBase f -> m (TxFactBase n f)
     loop fbase 
       = do { s <- checkpoint
-           ; let init_tx = TxFB { tfb_fbase = fbase
+           ; let init_tx :: TxFactBase n f
+                 init_tx = TxFB { tfb_fbase = fbase
                                 , tfb_cha   = NoChange
                                 , tfb_rg    = dgnilC
                                 , tfb_lbls  = setEmpty }
@@ -708,7 +717,8 @@ normalizeGraph :: forall n f e x .
                   NonLocal n => DG f n e x -> GraphWithFacts n f e x
 
 normalizeGraph g = (graphMapBlocks dropFact g, facts g)
-    where dropFact (DBlock _ b) = b
+    where dropFact :: DBlock t t1 t2 t3 -> Block t1 t2 t3
+          dropFact (DBlock _ b) = b
           facts :: DG f n e x -> FactBase f
           facts GNil = noFacts
           facts (GUnit _) = noFacts
@@ -718,7 +728,8 @@ normalizeGraph g = (graphMapBlocks dropFact g, facts g)
           exitFacts (JustO (DBlock f b)) = mapSingleton (entryLabel b) f
           bodyFacts :: LabelMap (DBlock f n C C) -> FactBase f
           bodyFacts body = mapFold f noFacts body
-            where f (DBlock f b) fb = mapInsert (entryLabel b) f fb
+            where f :: forall t a x. (NonLocal t) => DBlock a t C x -> LabelMap a -> LabelMap a
+                  f (DBlock f b) fb = mapInsert (entryLabel b) f fb
 
 --- implementation of the constructors (boring)
 
@@ -726,7 +737,8 @@ dgnil  = GNil
 dgnilC = GMany NothingO emptyBody NothingO
 
 dgSplice = U.splice fzCat
-  where fzCat (DBlock f b1) (DBlock _ b2) = DBlock f (b1 `U.cat` b2)
+  where fzCat :: DBlock f n e O -> DBlock t n O x -> DBlock f n e x
+        fzCat (DBlock f b1) (DBlock _ b2) = DBlock f (b1 `U.cat` b2)
 
 ----------------------------------------------------------------
 --       Utilities
index 2f20085..3b4e25d 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, ScopedTypeVariables, FlexibleInstances, RankNTypes #-}
+{-# LANGUAGE GADTs, ScopedTypeVariables, FlexibleInstances, RankNTypes, TypeFamilies #-}
 
 module Compiler.Hoopl.Util
   ( gUnitOO, gUnitOC, gUnitCO, gUnitCC
@@ -189,10 +189,12 @@ postorder_dfs_from_except blocks b visited =
             let cont' acc visited = cont (block:acc) visited in
             vchildren (get_children block) cont' acc (setInsert id visited)
       where id = entryLabel block
+   vchildren :: forall a. [block C C] -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a
    vchildren bs cont acc visited = next bs acc visited
       where next children acc visited =
                 case children of []     -> cont acc visited
                                  (b:bs) -> vnode b (next bs) acc visited
+   get_children :: forall l. LabelsPtr l => l -> [block C C]
    get_children block = foldr add_id [] $ targetLabels block
    add_id id rst = case lookupFact id blocks of
                       Just b -> b : rst
@@ -226,6 +228,7 @@ preorder_dfs_from_except blocks b visited =
                       else do mark (entryLabel b)
                               bs <- children $ get_children b
                               return $ b `cons` bs
+        get_children :: forall l. LabelsPtr l => l -> [block C C]
         get_children block = foldr add_id [] $ targetLabels block
         add_id id rst = case lookupFact id blocks of
                           Just b -> b : rst
@@ -241,7 +244,8 @@ labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x -
 labelsDefined GNil      = setEmpty
 labelsDefined (GUnit{}) = setEmpty
 labelsDefined (GMany _ body x) = mapFoldWithKey addEntry (exitLabel x) body
-  where addEntry label _ labels = setInsert label labels
+  where addEntry :: forall a. ElemOf LabelSet -> a -> LabelSet -> LabelSet
+        addEntry label _ labels = setInsert label labels
         exitLabel :: MaybeO x (block n C O) -> LabelSet
         exitLabel NothingO  = setEmpty
         exitLabel (JustO b) = setSingleton (entryLabel b)
@@ -250,7 +254,8 @@ labelsUsed :: forall block n e x. NonLocal (block n) => Graph' block n e x -> La
 labelsUsed GNil      = setEmpty
 labelsUsed (GUnit{}) = setEmpty
 labelsUsed (GMany e body _) = mapFold addTargets (entryTargets e) body 
-  where addTargets block labels = setInsertList (successors block) labels
+  where addTargets :: forall e. block n e C -> LabelSet -> LabelSet
+        addTargets block labels = setInsertList (successors block) labels
         entryTargets :: MaybeO e (block n O C) -> LabelSet
         entryTargets NothingO = setEmpty
         entryTargets (JustO b) = addTargets b setEmpty
index defdbf0..43bae47 100644 (file)
@@ -160,7 +160,7 @@ joinOutFacts lat n f = foldr join (fact_bot lat) facts
 -- operation on the map can be expressed in terms of the join on each
 -- element of the codomain:
 joinMaps :: Ord k => JoinFun v -> JoinFun (M.Map k v)
-joinMaps eltJoin l (OldFact old) (NewFact new) = M.foldWithKey add (NoChange, old) new
+joinMaps eltJoin l (OldFact old) (NewFact new) = M.foldrWithKey add (NoChange, old) new
   where 
     add k new_v (ch, joinmap) =
       case M.lookup k joinmap of
@@ -193,6 +193,7 @@ tfFoldBlock (f, m, l) bl bo = block bl
         oblock (BLast   n)       = l n
         oblock (b1 `BCat`    b2) = oblock b1 `cat` oblock b2
         oblock (n `BTail` b2)    = m n       `cat` oblock b2
+        cat :: forall b c a. (a -> b) -> (b -> c) -> a -> c
         cat f f' = f' . f
 
 
@@ -254,6 +255,7 @@ foldBlockNodesF3'' trips = block
         foldOO (BCat b1 b2) = foldOO b1 `cat` foldOO b2
         foldOC (BLast n)    = fl trips (JustC n)
         foldOC (BTail n b)  = fm trips n `cat` foldOC b
+        cat :: forall b c a. (a -> b) -> (b -> c) -> a -> c
         f `cat` g = g . f 
 
 data ScottBlock n a = ScottBlock
@@ -273,6 +275,7 @@ scottFoldBlock funs = block
         block (BCat    b1 b2) = block b1 `cat` block b2
         block (BHead   b  n)  = block b  `cat` sb_mid funs n
         block (BTail   n  b)  = sb_mid funs n `cat` block b
+        cat :: forall e x. a e O -> a O x -> a e x
         cat = sb_cat funs
 
 newtype NodeList n e x
@@ -287,6 +290,12 @@ fbnf3 (ff, fm, fl) block = unFF3 $ scottFoldBlock (ScottBlock f m l cat) block
     where f n = FF3 $ ff n
           m n = FF3 $ fm n
           l n = FF3 $ fl n
+          -- XXX Ew.
+          cat :: forall t t1 t2 t3 t4 t5 t6 t7 t8 t9 a b c e x.
+                 (IndexedCO x c b ~ IndexedCO t9 t7 t6,
+                  IndexedCO t8 t5 t6 ~ IndexedCO t4 t2 t1,
+                  IndexedCO t3 t t1 ~ IndexedCO e a b) =>
+                 FF3 t t1 t2 t3 t4 -> FF3 t5 t6 t7 t8 t9 -> FF3 a b c e x
           FF3 f `cat` FF3 f' = FF3 $ f' . f
 
 newtype FF3 a b c e x = FF3 { unFF3 :: IndexedCO e a b -> IndexedCO x c b }
@@ -296,15 +305,19 @@ blockToNodeList'' = finish . unList . scottFoldBlock (ScottBlock f m l cat)
     where f n = NL (JustC n, id, NothingC)
           m n = NL (NothingC, (n:), NothingC)
           l n = NL (NothingC, id, JustC n)
-          cat :: NodeList n e O -> NodeList n O x -> NodeList n e x
+          cat :: forall n t1 t2 t3. NodeList n t1 t2 -> NodeList n t2 t3 -> NodeList n t1 t3
           NL (e, ms, NothingC) `cat` NL (NothingC, ms', x) = NL (e, ms . ms', x)
+          finish :: forall t t1 t2 a. (t, [a] -> t1, t2) -> (t, t1, t2)
           finish (e, ms, x) = (e, ms [], x)
 
 
 
 blockToNodeList' :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C))
 blockToNodeList' b = unFNL $ foldBlockNodesF3''' ff fm fl b ()
-  where ff n () = PNL (n, [])
+  where ff :: forall n e. MaybeC e (n C O) -> () -> PNL n e
+        fm :: forall n e. n O O -> PNL n e -> PNL n e
+        fl :: forall n e x. MaybeC x (n O C) -> PNL n e -> FNL n e x
+        ff n () = PNL (n, [])
         fm n (PNL (first, mids')) = PNL (first, n : mids')
         fl n (PNL (first, mids')) = FNL (first, reverse mids', n)
 
@@ -335,6 +348,7 @@ foldBlockNodesF3''' ff fm fl = block
         blockOO (BCat b1 b2)    = blockOO b1 `cat` blockOO b2
         blockOC (BLast n)       = fl (JustC n)
         blockOC (BTail n b)     = fm n `cat` blockOC b
+        cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c
         f `cat` g = g . f 
 
 
@@ -364,6 +378,7 @@ foldBlockNodesF3' (ff, fm, fl) missingFirst missingLast = block
         blockOO (BCat b1 b2) = blockOO b1 `cat` blockOO b2
         blockOC (BLast n)    = fl n
         blockOC (BTail n b)  = fm n `cat` blockOC b
+        cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c
         f `cat` g = g . f 
 
 -- | Fold a function over every node in a block, forward or backward.
@@ -401,6 +416,7 @@ foldBlockNodesF3 (ff, fm, fl) = block
         block (b1 `BClosed` b2) = block b1 `cat` block b2
         block (b1 `BHead` n)    = block b1 `cat` fm n
         block (n `BTail` b2)    = fm n `cat` block b2
+        cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c
         cat f f' = f' . f
 foldBlockNodesF f = foldBlockNodesF3 (f, f, f)
 
@@ -413,6 +429,7 @@ foldBlockNodesB3 (ff, fm, fl) = block
         block (b1 `BClosed` b2) = block b1 `cat` block b2
         block (b1 `BHead` n)    = block b1 `cat` fm n
         block (n `BTail` b2)    = fm n `cat` block b2
+        cat :: forall a b c. (b -> c) -> (a -> b) -> a -> c
         cat f f' = f . f'
 foldBlockNodesB f = foldBlockNodesB3 (f, f, f)
 
@@ -429,6 +446,7 @@ foldGraphNodes f = graph
           lift _ NothingO         = id
           lift f (JustO thing)    = f thing
 
+          block :: Block n e x -> IndexedCO e a a -> IndexedCO x a a
           block = foldBlockNodesF f
 
 {-# DEPRECATED blockToNodeList, blockOfNodeList 
index 5007cd6..e3ce779 100644 (file)
@@ -61,17 +61,22 @@ varHasLit = mkFTransfer ft
       where toTop f v = Map.insert v Top f
   ft (Return _)             _ = mapEmpty
 
+type MaybeChange a = a -> Maybe a
 -- @ start cprop.tex
 --------------------------------------------------
 -- Rewriting: replace constant variables
-constProp :: FuelMonad m => FwdRewrite m Node ConstFact
+constProp :: forall m. FuelMonad m => FwdRewrite m Node ConstFact
 constProp = mkFRewrite cp
  where
+   cp :: Node e x -> ConstFact -> m (Maybe (Graph Node e x))
    cp node f
-     = return $ liftM nodeToG $ mapVN (lookup f) node
+     = return $ liftM insnToG $ mapVN (lookup f) node
+
+   mapVN :: (Var  -> Maybe Expr) -> MaybeChange (Node e x)
    mapVN      = mapEN . mapEE . mapVE
+   
+   lookup :: ConstFact -> Var -> Maybe Expr
    lookup f x = case Map.lookup x f of
                   Just (PElem v) -> Just $ Lit v
                   _              -> Nothing
 -- @ end cprop.tex
-   nodeToG = insnToG
index 74a560c..529bc4a 100644 (file)
@@ -103,12 +103,17 @@ instance EvalTarget Value where
               liftOp Gte  = b (>=)
               liftOp Lte  = b (<=)
               i = liftX I fromI
-              b = liftX B fromI
+              b = liftX B fromB
+
+              liftX :: Monad m => (a -> b) -> (b -> m a) -> (a -> a -> a) -> b -> b -> m b
               liftX up dwn = \ op x y -> do v_x <- dwn x
                                             v_y <- dwn y
                                             return $ up $ op v_x v_y
               fromI (I x) = return x
               fromI (B _) = throwError "fromI: got a B"
+              
+              fromB (I _) = throwError "fromB: got an I"
+              fromB (B x) = return x
 
 -- I'm under no delusion that the following example is useful,
 -- but it demonstrates how the evaluator can use a new kind
index 5762a47..3122991 100644 (file)
@@ -32,7 +32,11 @@ liveness = mkBTransfer live
     live n@(Cond _ tl fl)  f = addUses (fact f tl `S.union` fact f fl) n
     live n@(Call vs _ _ l) f = addUses (fact f l `S.difference` S.fromList vs) n
     live n@(Return _)      _ = addUses (fact_bot liveLattice) n
+
+    fact :: FactBase (S.Set Var) -> Label -> Live
     fact f l = fromMaybe S.empty $ lookupFact l f
+    
+    addUses :: S.Set Var -> Insn e x -> Live
     addUses = fold_EN (fold_EE addVar)
     addVar s (Var v) = S.insert v s
     addVar s _       = s
index 8299a19..72a5b14 100644 (file)
@@ -8,5 +8,5 @@ tests = map (\t -> "tests" ++ "/" ++ t)
              ["if-test", "if-test2", "if-test3", "if-test4"])
 
 main :: IO ()
-main = do mapM (\x -> parseTest x >> optTest x) tests
+main = do mapM (\x -> putStrLn ("Test:" ++ x) >> parseTest x >> optTest x) tests
           return ()
index 0c53e83..20b4ab2 100644 (file)
@@ -14,10 +14,11 @@ type Node = Insn
 
 --------------------------------------------------
 -- Simplification ("constant folding")
-simplify :: FuelMonad m => FwdRewrite m Node f
+simplify :: forall m f. FuelMonad m => FwdRewrite m Node f
 simplify = deepFwdRw simp
  where
-  simp node _ = return $ liftM nodeToG $ s_node node
+  simp :: forall e x. Node e x -> f -> m (Maybe (Graph Node e x))
+  simp node _ = return $ liftM insnToG $ 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)
@@ -44,4 +45,3 @@ simplify = deepFwdRw simp
   cmpOp Gte = Just (>=)
   cmpOp Lte = Just (<=)
   cmpOp _   = Nothing
-  nodeToG = insnToG