Merge branch 'master' of linux:/r/c--/papers/dfopt
[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 --
18 -- 1. import 'Debug.Trace'
19 --
20 -- 2. pass 'trace' as the 1st argument to the debug combinator
21 --
22 -- 3. pass 'const true' as the 2nd argument to the debug combinator
23 --------------------------------------------------------------------------------
24
25
26 debugFwdJoins :: forall n f . Show f => TraceFn -> ChangePred -> FwdPass n f -> FwdPass n f
27 debugBwdJoins :: forall n f . Show f => TraceFn -> ChangePred -> BwdPass n f -> BwdPass n f
28
29 type TraceFn = forall a . String -> a -> a
30 type ChangePred = ChangeFlag -> Bool
31
32 debugFwdJoins trace pred p = p { fp_lattice = debugJoins trace pred $ fp_lattice p }
33 debugBwdJoins trace pred p = p { bp_lattice = debugJoins trace pred $ bp_lattice p }
34
35 debugJoins :: Show f => TraceFn -> ChangePred -> DataflowLattice f -> DataflowLattice f
36 debugJoins trace showOutput l@(DataflowLattice {fact_extend = extend}) = l {fact_extend = extend'}
37 where
38 extend' l f1@(OldFact of1) f2@(NewFact nf2) =
39 if showOutput c then trace output res else res
40 where res@(c, f') = extend l f1 f2
41 output = case c of
42 SomeChange -> "+ Join@" ++ show l ++ ": " ++ show of1 ++ " `join` "
43 ++ show nf2 ++ " = " ++ show f'
44 NoChange -> "_ Join@" ++ show l ++ ": " ++ show nf2 ++ " <= " ++ show of1
45
46 --------------------------------------------------------------------------------
47 -- Functions we'd like to have, but don't know how to implement generically:
48 --------------------------------------------------------------------------------
49
50 -- type Showing n = forall e x . n e x -> String
51 -- debugFwdTransfers, debugFwdRewrites, debugFwdAll ::
52 -- forall n f . Show f => TraceFn -> Showing n -> FwdPass n f -> FwdPass n f
53 -- debugBwdTransfers, debugBwdRewrites, debugBwdAll ::
54 -- forall n f . Show f => TraceFn -> Showing n -> BwdPass n f -> BwdPass n f
55