Constant-propagation figure is now extracted automatically from John's code; some...
[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 , debugFwdTransfers , debugBwdTransfers
6 )
7 where
8
9 import Compiler.Hoopl.Dataflow
10 import Compiler.Hoopl.Show
11
12 --------------------------------------------------------------------------------
13 -- | Debugging combinators:
14 -- Each combinator takes a dataflow pass and produces
15 -- a dataflow pass that can output debugging messages.
16 -- You provide the function, we call it with the applicable message.
17 --
18 -- The most common use case is probably to:
19 --
20 -- 1. import 'Debug.Trace'
21 --
22 -- 2. pass 'trace' as the 1st argument to the debug combinator
23 --
24 -- 3. pass 'const true' as the 2nd argument to the debug combinator
25 --
26 -- There are two kinds of debugging messages for a join,
27 -- depending on whether the join is higher in the lattice than the old fact:
28 -- 1. If the join is higher, we show:
29 -- + Join@L: f1 `join` f2 = f'
30 -- where:
31 -- + indicates a change
32 -- L is the label where the join takes place
33 -- f1 is the old fact at the label
34 -- f2 is the new fact we are joining to f1
35 -- f' is the result of the join
36 -- 2. _ Join@L: f2 <= f1
37 -- where:
38 -- _ indicates no change
39 -- L is the label where the join takes place
40 -- f1 is the old fact at the label (which remains unchanged)
41 -- f2 is the new fact we joined with f1
42 --------------------------------------------------------------------------------
43
44
45 debugFwdJoins :: forall m n f . Show f => TraceFn -> ChangePred -> FwdPass m n f -> FwdPass m n f
46 debugBwdJoins :: forall m n f . Show f => TraceFn -> ChangePred -> BwdPass m n f -> BwdPass m n f
47
48 type TraceFn = forall a . String -> a -> a
49 type ChangePred = ChangeFlag -> Bool
50
51 debugFwdJoins trace pred p = p { fp_lattice = debugJoins trace pred $ fp_lattice p }
52 debugBwdJoins trace pred p = p { bp_lattice = debugJoins trace pred $ bp_lattice p }
53
54 debugJoins :: Show f => TraceFn -> ChangePred -> DataflowLattice f -> DataflowLattice f
55 debugJoins trace showPred l@(DataflowLattice {fact_extend = extend}) = l {fact_extend = extend'}
56 where
57 extend' l f1@(OldFact of1) f2@(NewFact nf2) =
58 if showPred c then trace output res else res
59 where res@(c, f') = extend l f1 f2
60 output = case c of
61 SomeChange -> "+ Join@" ++ show l ++ ": " ++ show of1 ++ " `join` "
62 ++ show nf2 ++ " = " ++ show f'
63 NoChange -> "_ Join@" ++ show l ++ ": " ++ show nf2 ++ " <= " ++ show of1
64
65 --------------------------------------------------------------------------------
66 -- Functions we'd like to have, but don't know how to implement generically:
67 --------------------------------------------------------------------------------
68
69 type ShowN n = forall e x . n e x -> String
70 type FPred n f = forall e x . n e x -> f -> Bool
71 type BPred n f = forall e x . n e x -> Fact x f -> Bool
72 debugFwdTransfers::
73 forall m n f . Show f => TraceFn -> ShowN n -> FPred n f -> FwdPass m n f -> FwdPass m n f
74 debugFwdTransfers trace showN showPred pass = pass { fp_transfer = transfers' }
75 where
76 (f, m, l) = getFTransfer3 $ fp_transfer pass
77 transfers' = mkFTransfer3 (wrap show f) (wrap show m) (wrap showFactBase l)
78 wrap :: forall e x . (Fact x f -> String) -> (n e x -> f -> Fact x f) -> n e x -> f -> Fact x f
79 wrap showOutF ft n f = if showPred n f then trace output res else res
80 where
81 res = ft n f
82 output = name ++ " transfer: " ++ show f ++ " -> " ++ showN n ++ " -> " ++ showOutF res
83 name = fact_name (fp_lattice pass)
84
85 debugBwdTransfers::
86 forall m n f . Show f => TraceFn -> ShowN n -> BPred n f -> BwdPass m n f -> BwdPass m n f
87 debugBwdTransfers trace showN showPred pass = pass { bp_transfer = transfers' }
88 where
89 (f, m, l) = getBTransfer3 $ bp_transfer pass
90 transfers' = mkBTransfer3 (wrap show f) (wrap show m) (wrap showFactBase l)
91 wrap :: forall e x . (Fact x f -> String) -> (n e x -> Fact x f -> f) -> n e x -> Fact x f -> f
92 wrap showInF ft n f = if showPred n f then trace output res else res
93 where
94 res = ft n f
95 output = name ++ " transfer: " ++ showInF f ++ " -> " ++ showN n ++ " -> " ++ show res
96 name = fact_name (bp_lattice pass)
97
98
99 -- debugFwdTransfers, debugFwdRewrites, debugFwdAll ::
100 -- forall m n f . Show f => TraceFn -> ShowN n -> FwdPass m n f -> FwdPass m n f
101 -- debugBwdTransfers, debugBwdRewrites, debugBwdAll ::
102 -- forall m n f . Show f => TraceFn -> ShowN n -> BwdPass m n f -> BwdPass m n f
103