Updated debugging output of debugJoins
[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 type ChangePred = ChangeFlag -> Bool
24 debugFwdJoins :: forall n f . Show f => TraceFn -> ChangePred -> FwdPass n f -> FwdPass n f
25 debugBwdJoins :: forall n f . Show f => TraceFn -> ChangePred -> BwdPass n f -> BwdPass n f
26
27 debugFwdJoins trace pred p = p { fp_lattice = debugJoins trace pred $ fp_lattice p }
28 debugBwdJoins trace pred p = p { bp_lattice = debugJoins trace pred $ bp_lattice p }
29
30 debugJoins :: Show f => TraceFn -> ChangePred -> DataflowLattice f -> DataflowLattice f
31 debugJoins trace showOutput l@(DataflowLattice {fact_extend = extend}) = l {fact_extend = extend'}
32 where
33 extend' l f1@(OldFact of1) f2@(NewFact nf2) =
34 if showOutput c then trace output res else res
35 where res@(c, f') = extend l f1 f2
36 output = case c of
37 SomeChange -> "+ Join@" ++ show l ++ ": " ++ show of1 ++ " |_| "
38 ++ show nf2 ++ " = " ++ show f'
39 NoChange -> "_ Join@" ++ show l ++ ": " ++ show nf2 ++ " <= " ++ show of1
40
41 --------------------------------------------------------------------------------
42 -- Functions we'd like to have, but don't know how to implement generically:
43 --------------------------------------------------------------------------------
44
45 -- type Showing n = forall e x . n e x -> String
46 -- debugFwdTransfers, debugFwdRewrites, debugFwdAll ::
47 -- forall n f . Show f => TraceFn -> Showing n -> FwdPass n f -> FwdPass n f
48 -- debugBwdTransfers, debugBwdRewrites, debugBwdAll ::
49 -- forall n f . Show f => TraceFn -> Showing n -> BwdPass n f -> BwdPass n f
50