First hack at higher-order debugging functions for transfers.
authorJoao Dias <dias@cs.tufts.edu>
Thu, 22 Apr 2010 21:57:08 +0000 (17:57 -0400)
committerJoao Dias <dias@cs.tufts.edu>
Thu, 22 Apr 2010 21:57:08 +0000 (17:57 -0400)
src/Compiler/Hoopl/Debug.hs
src/Compiler/Hoopl/Show.hs

index 66defd6..dc0abc4 100644 (file)
@@ -2,10 +2,12 @@
 
 module Compiler.Hoopl.Debug 
   ( TraceFn , debugFwdJoins , debugBwdJoins
+  , debugFwdTransfers , debugBwdTransfers
   )
 where
 
 import Compiler.Hoopl.Dataflow
+import Compiler.Hoopl.Show
 
 --------------------------------------------------------------------------------
 -- | Debugging combinators:
@@ -33,10 +35,10 @@ debugFwdJoins trace pred p = p { fp_lattice = debugJoins trace pred $ fp_lattice
 debugBwdJoins trace pred p = p { bp_lattice = debugJoins trace pred $ bp_lattice p }
 
 debugJoins :: Show f => TraceFn -> ChangePred -> DataflowLattice f -> DataflowLattice f
-debugJoins trace showOutput l@(DataflowLattice {fact_extend = extend}) = l {fact_extend = extend'}
+debugJoins trace showPred l@(DataflowLattice {fact_extend = extend}) = l {fact_extend = extend'}
   where
    extend' l f1@(OldFact of1) f2@(NewFact nf2) =
-     if showOutput c then trace output res else res
+     if showPred c then trace output res else res
        where res@(c, f') = extend l f1 f2
              output = case c of
                         SomeChange -> "+ Join@" ++ show l ++ ": " ++ show of1 ++ " |_| "
@@ -47,9 +49,38 @@ debugJoins trace showOutput l@(DataflowLattice {fact_extend = extend}) = l {fact
 -- Functions we'd like to have, but don't know how to implement generically:
 --------------------------------------------------------------------------------
 
--- type Showing n = forall e x . n e x -> String
+type ShowN n   = forall e x . n e x ->      String
+type FPred n f = forall e x . n e x -> f        -> Bool
+type BPred n f = forall e x . n e x -> Fact x f -> Bool
+debugFwdTransfers::
+  forall n f . Show f => TraceFn -> ShowN n -> FPred n f -> FwdPass n f -> FwdPass 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)
+    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
+        res    = ft n f
+        output = name ++ " transfer: " ++ show f ++ " -> " ++ showN n ++ " -> " ++ showOutF res
+    name = fact_name (fp_lattice pass)
+    
+debugBwdTransfers::
+  forall n f . Show f => TraceFn -> ShowN n -> BPred n f -> BwdPass n f -> BwdPass 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)
+    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
+        res    = ft n f
+        output = name ++ " transfer: " ++ showInF f ++ " -> " ++ showN n ++ " -> " ++ show res
+    name = fact_name (bp_lattice pass)
+    
+
 -- debugFwdTransfers, debugFwdRewrites, debugFwdAll ::
---   forall n f . Show f => TraceFn -> Showing n -> FwdPass n f -> FwdPass n f
+--   forall n f . Show f => TraceFn -> ShowN n -> FwdPass n f -> FwdPass n f
 -- debugBwdTransfers, debugBwdRewrites, debugBwdAll ::
---   forall n f . Show f => TraceFn -> Showing n -> BwdPass n f -> BwdPass n f
+--   forall n f . Show f => TraceFn -> ShowN n -> BwdPass n f -> BwdPass n f
 
index 381ed8d..bf569d8 100644 (file)
@@ -1,11 +1,12 @@
 {-# LANGUAGE RankNTypes, GADTs, ScopedTypeVariables, FlexibleContexts #-}
 
 module Compiler.Hoopl.Show 
-  ( showGraph
+  ( showGraph, showFactBase
   )
 where
 
 import Compiler.Hoopl.Graph
+import Compiler.Hoopl.Label
 
 --------------------------------------------------------------------------------
 -- Prettyprinting
@@ -34,3 +35,6 @@ showGraph node = g
 open :: (a -> String) -> MaybeO z a -> String
 open _ NothingO  = ""
 open p (JustO n) = p n
+
+showFactBase :: Show f => FactBase f -> String
+showFactBase = show . factBaseList