X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FZipDataflow.hs;h=4355775a29cf27c9a7a16e08ff486f1e81b67fc3;hp=39a4798ee49895c7041f717a8288bc0c494afe48;hb=edc0bafd3fcd01b85a2e8894e5dfe149eb0e0857;hpb=5dc8b425443200a5160b9d1399aca1808bfcffee

diff --git a/compiler/cmm/ZipDataflow.hs b/compiler/cmm/ZipDataflow.hs
index 39a4798..4355775 100644
--- a/compiler/cmm/ZipDataflow.hs
+++ b/compiler/cmm/ZipDataflow.hs
@@ -1,6 +1,5 @@
-{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-}
-{-# OPTIONS -fglasgow-exts #-}
--- -fglagow-exts for kind signatures
+{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, KindSignatures,
+             FlexibleContexts #-}
 
 module ZipDataflow
     ( DebugNodes(), RewritingDepth(..), LastOutFacts(..)
@@ -29,10 +28,8 @@ import qualified ZipCfg as G
 
 import Maybes
 import Outputable
-import Panic
 
 import Control.Monad
-import Maybe
 
 {- 
 
@@ -505,7 +502,7 @@ forward_sol check_maybe = forw
   forw rewrite name start_facts transfers rewrites =
    let anal_f :: DFM a b -> a -> Graph m l -> DFM a b
        anal_f finish in' g =
-           do { fwd_pure_anal name emptyBlockEnv transfers in' g; finish }
+           do { _ <- fwd_pure_anal name emptyBlockEnv transfers in' g; finish }
 
        solve :: DFM a b -> a -> Graph m l -> Fuel -> DFM a (b, Fuel)
        solve finish in_fact (Graph entry blockenv) fuel =
@@ -530,8 +527,14 @@ forward_sol check_maybe = forw
                ; b <-  finish
                ; return (b, fuel)
                }
+
        -- The need for both k1 and k2 suggests that maybe there's an opportunity
        -- for improvement here -- in most cases, they're the same...
+       rec_rewrite :: forall t bI bW.
+                      Maybe (AGraph m l) -> t -> DFM a bW
+                   -> (t -> Fuel -> DFM a bI)
+                   -> (bW -> Fuel -> DFM a bI)
+                   -> a -> Fuel -> DFM a bI
        rec_rewrite rewritten analyzed finish k1 k2 in' fuel =
          case check_maybe fuel rewritten of -- fr_first rewrites id idfact of
            Nothing -> k1 analyzed fuel
@@ -572,7 +575,7 @@ mk_set_or_save :: (DataflowAnalysis df, Monad (df a), Outputable a) =>
                   (BlockId -> Bool) -> LastOutFacts a -> df a ()
 mk_set_or_save is_local (LastOutFacts l) = mapM_ set_or_save_one l
     where set_or_save_one (id, a) =
-              if is_local id then setFact id a else pprTrace "addLastOutFact" (ppr $ length l) $ addLastOutFact (id, a)
+              if is_local id then setFact id a else addLastOutFact (id, a)
 
 
 
@@ -591,7 +594,6 @@ forward_rew
         -> DFM a (ForwardFixedPoint m l a (Graph m l), Fuel)
 forward_rew check_maybe = forw
   where
-    solve = forward_sol check_maybe
     forw :: RewritingDepth
          -> BlockEnv a
          -> PassName
@@ -609,7 +611,8 @@ forward_rew check_maybe = forw
            in_fact `seq` g `seq`
             let Graph entry blockenv = g
                 blocks = G.postorder_dfs_from blockenv entry
-            in do { solve depth name start transfers rewrites in_fact g fuel
+            in do { _ <- forward_sol check_maybe depth name start 
+                                     transfers rewrites in_fact g fuel
                   ; eid <- freshBlockId "temporary entry id"
                   ; (rewritten, fuel) <-
                       rew_tail (ZFirst eid) in_fact entry emptyBlockEnv fuel
@@ -617,11 +620,18 @@ forward_rew check_maybe = forw
                   ; a <- finish
                   ; return (a, lgraphToGraph (LGraph eid rewritten), fuel)
                   }
+
+          don't_rewrite :: forall t.
+                           BlockEnv a -> DFM a t -> a
+                        -> Graph m l -> Fuel
+                        -> DFM a (t, Graph m l, Fuel)
           don't_rewrite facts finish in_fact g fuel =
-              do  { solve depth name facts transfers rewrites in_fact g fuel
+              do  { _ <- forward_sol check_maybe depth name facts 
+                                     transfers rewrites in_fact g fuel
                   ; a <- finish
                   ; return (a, g, fuel)
                   }
+
           inner_rew :: DFM a f -> a -> Graph m l -> Fuel -> DFM a (f, Graph m l, Fuel)
           inner_rew f i g fu = getAllFacts >>= \facts -> inner_rew' facts f i g fu
               where inner_rew' = case depth of RewriteShallow -> don't_rewrite
@@ -635,6 +645,7 @@ forward_rew check_maybe = forw
                  ; let fp = FFP cfp last_outs
                  ; return (fp, fuel)
                  }
+
 -- JD: WHY AREN'T WE TAKING ANY FUEL HERE?
           rewrite_blocks :: [Block m l] -> (BlockEnv (Block m l))
                          -> Fuel -> DFM a (BlockEnv (Block m l), Fuel)
@@ -684,8 +695,8 @@ forward_rew check_maybe = forw
           either_last rewrites in' (LastOther l) = fr_last rewrites l in'
           check_facts in' (LastOther l) =
             let LastOutFacts last_outs = ft_last_outs transfers l in'
-            in mapM (uncurry checkFactMatch) last_outs
-          check_facts _ LastExit = return []
+            in mapM_ (uncurry checkFactMatch) last_outs
+          check_facts _ LastExit = return ()
       in  fixed_pt_and_fuel
 
 lastOutFacts :: DFM f (LastOutFacts f)
@@ -781,7 +792,7 @@ backward_sol check_maybe = back
                                      my_trace "analysis rewrites last node"
                                       (ppr l <+> pprGraph g') $
                                       subsolve g exit_fact fuel
-                    ; set_head_fact h a fuel
+                    ; _ <- set_head_fact h a fuel
                     ; return fuel }
 
          in do { fuel <- run "backward" name set_block_fact blocks fuel
@@ -982,7 +993,7 @@ instance FixedPoint ForwardFixedPoint where
 
 
 dump_things :: Bool
-dump_things = True
+dump_things = False
 
 my_trace :: String -> SDoc -> a -> a
 my_trace = if dump_things then pprTrace else \_ _ a -> a
@@ -1030,8 +1041,9 @@ run dir name do_block blocks b =
      pprFacts depth n env =
          my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$
                         (nest 2 $ vcat $ map pprFact $ blockEnvToList env))
-     pprFact  (id, a) = hang (ppr id <> colon) 4 (ppr a)
 
+pprFact :: (Outputable a, Outputable b) => (a,b) -> SDoc
+pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
 
 f4sep :: [SDoc] -> SDoc
 f4sep [] = fsep []