Remembered to add the new debugging module to the git repository...
[packages/hoopl.git] / src / Compiler / Hoopl / Debug.hs
1 {-# LANGUAGE RankNTypes, GADTs, ScopedTypeVariables, FlexibleContexts #-}
2
3 module Compiler.Hoopl.Debug
4 ( TraceFn , debugFwdJoins , debugBwdJoins
5 )
6 where
7
8 import Compiler.Hoopl.Dataflow
9
10 --------------------------------------------------------------------------------
11 -- Debugging combinators:
12 -- Each combinator takes a dataflow pass and produces
13 -- a dataflow pass that can output debugging messages.
14 -- You provide the function, we call it with the applicable message.
15 --
16 -- The most common use case is probably to:
17 -- 1. import Debug.Trace
18 -- 2. pass trace as the 1st argument to the debug combinator
19 --------------------------------------------------------------------------------
20
21
22 type TraceFn = forall a . String -> a -> a
23 debugFwdJoins :: forall n f . Show f => TraceFn -> FwdPass n f -> FwdPass n f
24 debugBwdJoins :: forall n f . Show f => TraceFn -> BwdPass n f -> BwdPass n f
25
26 debugFwdJoins trace p = p { fp_lattice = debugJoins trace $ fp_lattice p }
27 debugBwdJoins trace p = p { bp_lattice = debugJoins trace $ bp_lattice p }
28
29 debugJoins :: Show f => TraceFn -> DataflowLattice f -> DataflowLattice f
30 -- JoinFun a -> JoinFun a
31 debugJoins trace l@(DataflowLattice {fact_extend = extend}) = l {fact_extend = extend'}
32 where
33 extend' l f1@(OldFact of1) f2@(NewFact nf2) =
34 case extend l f1 f2 of
35 res@(NoChange, _) -> res
36 res@(SomeChange, f') ->
37 trace ("Join@" ++ show l ++ ": " ++ show of1 ++ " + " ++ show nf2 ++ " = " ++ show f') res
38
39 --------------------------------------------------------------------------------
40 -- Functions we'd like to have, but don't know how to implement generically:
41 --------------------------------------------------------------------------------
42
43 -- type Showing n = forall e x . n e x -> String
44 -- debugFwdTransfers, debugFwdRewrites, debugFwdAll ::
45 -- forall n f . Show f => TraceFn -> Showing n -> FwdPass n f -> FwdPass n f
46 -- debugBwdTransfers, debugBwdRewrites, debugBwdAll ::
47 -- forall n f . Show f => TraceFn -> Showing n -> BwdPass n f -> BwdPass n f
48