Prepare dph for a vectInfoVar type change master
authorBartosz Nitka <bnitka@fb.com>
Tue, 5 Jul 2016 14:20:23 +0000 (07:20 -0700)
committerBartosz Nitka <bnitka@fb.com>
Tue, 5 Jul 2016 14:20:23 +0000 (07:20 -0700)
vectInfoVar uses deterministic sets now, see
Note [Deterministic UniqFM] for more details.

dph-plugin/DPH/Core/Pretty.hs
dph-plugin/DPH/Pass/Summon.hs

index 54bcd97..499adc3 100644 (file)
@@ -1,5 +1,5 @@
 
-module DPH.Core.Pretty 
+module DPH.Core.Pretty
         ( module DPH.Base.Pretty
         , pprModGuts
         , pprTopBinds)
@@ -17,13 +17,13 @@ import DataCon
 import Literal
 import Id
 import Unique
-import qualified UniqFM as UFM
+import qualified UniqDFM as UDFM
 
 -- Guts -----------------------------------------------------------------------
 pprModGuts :: ModGuts -> Doc
 pprModGuts guts
  = vcat
- [ text "Exports:" 
+ [ text "Exports:"
         <+> ppr (mg_exports guts)
  , empty
 
@@ -42,10 +42,10 @@ instance Pretty AvailInfo where
         AvailTC n _     -> ppr n
 
 
--- | The VectInfo maps names to their vectorised versions. 
+-- | The VectInfo maps names to their vectorised versions.
 instance Pretty VectInfo where
  ppr vi
-  = ppr $ UFM.eltsUFM (vectInfoVar vi)
+  = ppr $ UDFM.eltsUDFM (vectInfoVar vi)
 
 
 -- Top Binds ------------------------------------------------------------------
@@ -55,14 +55,14 @@ pprTopBinds binds
 
 pprTopBind  :: Pretty a => Bind a -> Doc
 pprTopBind (NonRec binder expr)
-  =    pprBinding (binder, expr) 
+  =    pprBinding (binder, expr)
   <$$> empty
 
 pprTopBind (Rec [])
   = text "Rec { }"
 
 pprTopBind (Rec bb@(b:bs))
-  = vcat 
+  = vcat
   [ text "Rec {"
   , vcat [empty <$$> pprBinding b | b <- bb]
   , text "end Rec }"
@@ -75,7 +75,7 @@ pprBinding (binder, x)
         =   ppr binder
         <+> breakWhen (not $ isSimpleX x)
         <+> equals <+> align (ppr x)
-              
+
 
 
 -- Expr -----------------------------------------------------------------------
@@ -83,10 +83,10 @@ instance Pretty a => Pretty (Expr a) where
  pprPrec d xx
   = case xx of
         Var  ident
-         -> pprBound ident 
+         -> pprBound ident
 
         -- Discard types and coersions
-        Type _          -> empty 
+        Type _          -> empty
         Coercion _      -> empty
 
         -- Literals.
@@ -101,8 +101,8 @@ instance Pretty a => Pretty (Expr a) where
          -> pprParen' (d > 2)
          $  let (bndrs, body) = collectBinders xx
             in  text "\\" <> sep (map ppr bndrs)
-                 <> text "." 
-                 <> (nest 2 
+                 <> text "."
+                 <> (nest 2
                         $ (breakWhen $ not $ isSimpleX body)
                          <> ppr body)
 
@@ -114,13 +114,13 @@ instance Pretty a => Pretty (Expr a) where
          |  otherwise
          -> pprParen' (d > 10)
          $  ppr x1
-                <> nest 2 (breakWhen (not $ isSimpleX x2) 
+                <> nest 2 (breakWhen (not $ isSimpleX x2)
                                 <> pprPrec 11 x2)
 
         -- Destructors.
         Case x1 var ty [(con, binds, x2)]
          -> pprParen' (d > 2)
-         $  text "let" 
+         $  text "let"
                 <+> (fill 12 (ppr con <+> hsep (map ppr binds)))
 --                <>  breakWhen (not $ isSimpleX x1)
                         <+>  text "<-"
@@ -130,8 +130,8 @@ instance Pretty a => Pretty (Expr a) where
 
         Case x1 var ty alts
          -> pprParen' (d > 2)
-         $  (nest 2 
-                $ text "case" <+> ppr x1 <+> text "of" 
+         $  (nest 2
+                $ text "case" <+> ppr x1 <+> text "of"
                 <+> ppr var
                 <+> lbrace <> line
                         <> vcat (punctuate semi $ map pprAlt alts))
@@ -140,11 +140,11 @@ instance Pretty a => Pretty (Expr a) where
         -- Binding.
         Let (NonRec b x1) x2
          -> pprParen' (d > 2)
-         $  text "let" 
+         $  text "let"
                 <+> fill 12 (ppr b)
-                <+> equals 
-                <+> ppr x1 
-                <+> text "in" 
+                <+> equals
+                <+> ppr x1
+                <+> text "in"
                 <$$> ppr x2
 
         Let (Rec bxs) x2
@@ -163,7 +163,7 @@ instance Pretty a => Pretty (Expr a) where
 -- Alt ------------------------------------------------------------------------
 pprAlt :: Pretty a => (AltCon, [a], Expr a) -> Doc
 pprAlt (con, binds, x)
-        = ppr con <+> (hsep $ map ppr binds) 
+        = ppr con <+> (hsep $ map ppr binds)
         <+> nest 1 (line <> nest 3 (text "->" <+> ppr x))
 
 instance Pretty AltCon where
@@ -211,7 +211,7 @@ instance Pretty CoreBndr where
 
 
 instance Pretty DataCon where
- ppr con 
+ ppr con
         = ppr (dataConName con)
 
 instance Pretty Name where
index aea1d1a..9645cd6 100644 (file)
@@ -1,7 +1,7 @@
 
 -- The Summoner is a demand-driven inliner.
 --   We give it the name of a function we want summoned, and it will inline
---   everything it can find into it. 
+--   everything it can find into it.
 --
 --   The summoner ignores GHC generated inliner heuristics (UnfoldingGuidance)
 --   as well as NOINLINE pragmas for bindings in the module being compiled.
@@ -21,27 +21,27 @@ import CoreMonad
 import Avail
 import Data.Maybe
 import Data.Set                 (Set)
-import qualified UniqFM         as UFM
+import qualified UniqDFM        as UDFM
 import qualified Data.Set       as Set
 import Control.Monad
 import Debug.Trace
 
 -- Pass -----------------------------------------------------------------------
 passSummon :: ModGuts -> CoreM ModGuts
-passSummon guts 
+passSummon guts
  = do   let tops        = mg_binds guts
 
         -- Get the names of the vectorised versions of all exported bindings.
         let nsExported  = [ n | Avail n <- mg_exports guts]
-        let nsExported_vect     
+        let nsExported_vect
                 = catMaybes
-                $ map (UFM.lookupUFM (vectInfoVar $ mg_vect_info guts))
+                $ map (UDFM.lookupUDFM (vectInfoVar $ mg_vect_info guts))
                 $ nsExported
 
         -- Summon all of the vectorised things.
-        let summonMe    
-                = Set.fromList 
-                $ map snd 
+        let summonMe
+                = Set.fromList
+                $ map snd
                 $ nsExported_vect
 
         tops'   <- mapM (summonTop summonMe tops) tops
@@ -58,7 +58,7 @@ summonTop
 
 summonTop bsSet tops bind
  = case bind of
-        NonRec b x      
+        NonRec b x
          -> do  (b', x')        <- goSummon (b, x)
                 return $ NonRec b' x'
 
@@ -89,7 +89,7 @@ summonX :: [CoreBind]
 summonX tops xx
  = let down     = summonX tops
    in case xx of
-        Var n   
+        Var n
          -> trace (renderIndent $ text "look at " <> ppr n)
          $  case lookupBind tops n of
                 Nothing -> return xx
@@ -101,7 +101,7 @@ summonX tops xx
         Let bnd x       -> liftM2 Let (summonB tops bnd) (down x)
 
         Case x b t alts -> liftM4 Case  (down x)
-                                (return b) (return t) 
+                                (return b) (return t)
                                 (mapM (summonA tops) alts)
 
         Cast x co       -> liftM2 Cast  (down x)   (return co)
@@ -111,7 +111,7 @@ summonX tops xx
 
 
 -- | Summon into an alternative.
-summonA :: [CoreBind] 
+summonA :: [CoreBind]
         -> (AltCon, [CoreBndr], Expr CoreBndr)
         -> CoreM (AltCon, [CoreBndr], Expr CoreBndr)
 
@@ -127,7 +127,7 @@ summonB :: [CoreBind]
 
 summonB tops bb
  = case bb of
-        NonRec b x      
+        NonRec b x
          -> liftM2 NonRec (return b) (summonX tops x)
 
         Rec bxs
@@ -136,8 +136,8 @@ summonB tops bb
                 return          $ Rec $ zip bs xs
 
 
-lookupBind 
-        :: [CoreBind] 
+lookupBind
+        :: [CoreBind]
         -> CoreBndr
         -> Maybe (Expr CoreBndr)
 lookupBind tops b