{-# LANGUAGE CPP, RankNTypes, GADTs, ScopedTypeVariables, FlexibleContexts #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Safe #-} #endif module Compiler.Hoopl.Debug ( TraceFn , debugFwdJoins , debugBwdJoins , debugFwdTransfers , debugBwdTransfers ) where import Compiler.Hoopl.Dataflow import Compiler.Hoopl.Show -------------------------------------------------------------------------------- -- | 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 -- -- 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 -------------------------------------------------------------------------------- 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 type TraceFn = forall a . String -> a -> a type ChangePred = ChangeFlag -> Bool 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_join = join}) = l {fact_join = join'} where join' l f1@(OldFact of1) f2@(NewFact nf2) = if showPred c then trace output res else res where res@(c, f') = join 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 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 m n f . Show f => TraceFn -> ShowN n -> FwdPass m n f -> FwdPass m n f -- debugBwdTransfers, debugBwdRewrites, debugBwdAll :: -- forall m n f . Show f => TraceFn -> ShowN n -> BwdPass m n f -> BwdPass m n f