Constant-propagation figure is now extracted automatically from John's code; some...
[packages/hoopl.git] / src / Compiler / Hoopl / Debug.hs
index 8f817db..d03320e 100644 (file)
 
 module Compiler.Hoopl.Debug 
   ( TraceFn , debugFwdJoins , debugBwdJoins
+  , debugFwdTransfers , debugBwdTransfers
   )
 where
 
 import Compiler.Hoopl.Dataflow
+import Compiler.Hoopl.Show
 
 --------------------------------------------------------------------------------
--- Debugging combinators:
+-- Debugging combinators:
 -- Each combinator takes a dataflow pass and produces
 -- a dataflow pass that can output debugging messages.
 -- You provide the function, we call it with the applicable message.
 -- 
 -- The most common use case is probably to:
---  1. import Debug.Trace
---  2. pass trace as the 1st argument to the debug combinator
+--
+--   1. import 'Debug.Trace'
+--
+--   2. pass 'trace' as the 1st argument to the debug combinator
+--
+--   3. pass 'const true' as the 2nd argument to the debug combinator
+--
+-- There are two kinds of debugging messages for a join,
+-- depending on whether the join is higher in the lattice than the old fact:
+--   1. If the join is higher, we show:
+--         + Join@L: f1 `join` f2 = f'
+--      where:
+--        + indicates a change
+--        L is the label where the join takes place
+--        f1 is the old fact at the label
+--        f2 is the new fact we are joining to f1
+--        f' is the result of the join
+--   2. _ Join@L: f2 <= f1
+--      where:
+--        _ indicates no change
+--        L is the label where the join takes place
+--        f1 is the old fact at the label (which remains unchanged)
+--        f2 is the new fact we joined with f1
 --------------------------------------------------------------------------------
 
 
-type TraceFn = forall a . String -> a -> a
-debugFwdJoins :: forall n f . Show f => TraceFn -> FwdPass n f -> FwdPass n f
-debugBwdJoins :: forall n f . Show f => TraceFn -> BwdPass n f -> BwdPass n f
+debugFwdJoins :: forall m n f . Show f => TraceFn -> ChangePred -> FwdPass m n f -> FwdPass m n f
+debugBwdJoins :: forall m n f . Show f => TraceFn -> ChangePred -> BwdPass m n f -> BwdPass m n f
 
-debugFwdJoins trace p = p { fp_lattice = debugJoins trace $ fp_lattice p }
-debugBwdJoins trace p = p { bp_lattice = debugJoins trace $ bp_lattice p }
+type TraceFn    = forall a . String -> a -> a
+type ChangePred = ChangeFlag -> Bool
 
-debugJoins :: Show f => TraceFn -> DataflowLattice f -> DataflowLattice f
--- JoinFun a -> JoinFun a 
-debugJoins trace l@(DataflowLattice {fact_extend = extend}) = l {fact_extend = extend'}
+debugFwdJoins trace pred p = p { fp_lattice = debugJoins trace pred $ fp_lattice p }
+debugBwdJoins trace pred p = p { bp_lattice = debugJoins trace pred $ bp_lattice p }
+
+debugJoins :: Show f => TraceFn -> ChangePred -> DataflowLattice f -> DataflowLattice f
+debugJoins trace showPred l@(DataflowLattice {fact_extend = extend}) = l {fact_extend = extend'}
   where
    extend' l f1@(OldFact of1) f2@(NewFact nf2) =
-     case extend l f1 f2 of
-       res@(NoChange, _)    -> res
-       res@(SomeChange, f') ->
-         trace ("Join@" ++ show l ++ ": " ++ show of1 ++ " + " ++ show nf2 ++ " = " ++ show f') 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 ++ " `join` "
+                                                                  ++ show nf2 ++ " = " ++ show f'
+                        NoChange   -> "_ Join@" ++ show l ++ ": " ++ show nf2 ++ " <= " ++ show of1
 
 --------------------------------------------------------------------------------
 -- 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 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) = 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
+        res    = ft n f
+        output = name ++ " transfer: " ++ show f ++ " -> " ++ showN n ++ " -> " ++ showOutF res
+    name = fact_name (fp_lattice pass)
+    
+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) = 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
+        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 m n f . Show f => TraceFn -> ShowN n -> FwdPass m n f -> FwdPass m n f
 -- debugBwdTransfers, debugBwdRewrites, debugBwdAll ::
---   forall n f . Show f => TraceFn -> Showing n -> BwdPass n f -> BwdPass n f
+--   forall m n f . Show f => TraceFn -> ShowN n -> BwdPass m n f -> BwdPass m n f