dph-plugin: add first-cut summoner that only works on NonRec bindings
authorBen Lippmeier <benl@ouroborus.net>
Thu, 2 Aug 2012 04:19:11 +0000 (14:19 +1000)
committerBen Lippmeier <benl@ouroborus.net>
Thu, 2 Aug 2012 04:19:11 +0000 (14:19 +1000)
dph-examples/dph-examples.cabal
dph-plugin/DPH/Core/Pretty.hs
dph-plugin/DPH/Pass/Dump.hs
dph-plugin/DPH/Pass/Summon.hs [new file with mode: 0644]
dph-plugin/DPH/Pipeline.hs

index a66ed7e..62bfef4 100644 (file)
@@ -17,130 +17,130 @@ Synopsis:            Data Parallel Haskell example programs.
 -- Smoke ----------------------------------------------------------------------
 -- examples/smoke/data
 Executable dph-smoke-bool
-  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
+  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.0.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
   Main-is:        Main.hs
   other-modules:  Vectorised
   hs-source-dirs: examples/smoke/data/Bool
-  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000
+  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000
 
 
 -- examples/smoke/prims
 Executable dph-smoke-concat
-  build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
+  build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.0.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
   main-is:        Main.hs
   other-modules:  Vectorised
   hs-source-dirs: examples/smoke/prims/Concat
-  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000
+  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000
 
 
 Executable dph-smoke-sumsq
-  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
+  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.0.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
   Main-is:        Main.hs
   other-modules:  Vector
                   Vectorised
                   Timing Randomish
   hs-source-dirs: examples/smoke/prims/SumSquares/dph lib
-  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000
+  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000
  
  
 Executable dph-smoke-evens
-  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
+  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.0.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
   Main-is:        Main.hs
   other-modules:  Vector
                   Vectorised
                   Timing Randomish
   hs-source-dirs: examples/smoke/prims/Evens/dph lib
-  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000
+  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000
 
 
 -- examples/smoke/sharing
 Executable dph-smoke-indices
-  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
+  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.0.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
   Main-is:        Main.hs
   other-modules:  Vectorised
   hs-source-dirs: examples/smoke/sharing/Indices lib
-  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000
+  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000
  
  
 Executable dph-smoke-rank
-  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
+  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.0.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
   Main-is:        Main.hs
   other-modules:  Vectorised Util Timing Randomish
   hs-source-dirs: examples/smoke/sharing/Rank lib
-  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000
+  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000
 
 
 Executable dph-smoke-reverse
-  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
+  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.0.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
   Main-is:        Main.hs
   other-modules:  Vectorised Randomish
   hs-source-dirs: examples/smoke/sharing/Reverse lib
-  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000
+  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000
 
 
 -- Imaginary ------------------------------------------------------------------
 -- Executable dph-imaginary-primes
---   Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
+--   Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.0.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
 --   Main-is:        Main.hs
 --   other-modules:  Vectorised
 --   hs-source-dirs: examples/imaginary/Primes lib
---   ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000
+--   ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000
 
 Executable dph-imaginary-words
-  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
+  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.0.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
   Main-is:        Main.hs
   other-modules:  Vectorised
   hs-source-dirs: examples/imaginary/Words lib
-  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000
+  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000
 
 
 -- Spectral -------------------------------------------------------------------
 Executable dph-spectral-dotp
-  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
+  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.0.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
   Main-is:        Main.hs
   other-modules:  Vector
                   Vectorised
                   Timing Randomish
   hs-source-dirs: examples/spectral/DotProduct/dph lib
-  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000
+  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000
 
 
 Executable dph-spectral-smvm
-  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
+  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.0.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
   Main-is:        Main.hs
   other-modules:  Vectorised
                   Timing
   hs-source-dirs: examples/spectral/SMVM/dph lib
-  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000
+  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000
 
 
 Executable dph-spectral-quickhull
-  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
+  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.0.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
   Main-is:        Main.hs
   other-modules:  Vectorised
                   Timing Points2D.Types SVG
   hs-source-dirs: examples/spectral/QuickHull/dph examples/spectral/QuickHull/lib lib
-  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000
+  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000
 
 
 Executable dph-spectral-quickhull-vector
-  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
+  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.0.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
   Main-is:        Main.hs
   other-modules:  QuickHullIO
                   QuickHullSplit
                   QuickHullVector
                   Timing Points2D.Types SVG
   hs-source-dirs: examples/spectral/QuickHull/vector examples/spectral/QuickHull/lib lib
-  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000
+  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000
 
 
 Executable dph-spectral-quicksort
-  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
+  Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.0.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
   Main-is:        Main.hs
   other-modules:  Vectorised
                   Timing
   hs-source-dirs: examples/spectral/QuickSort/dph lib
-  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000
+  ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000
 
 
 -- Real -----------------------------------------------------------------------
@@ -154,9 +154,9 @@ Executable dph-spectral-quicksort
 --                     Timing Points2D.Types Points2D.Generate
 --                     System.Console.ParseArgs
 --                     Gloss.MainArgs Gloss.Draw Gloss.Config
---    Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*, gloss == 1.6.*
+--    Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.0.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*, gloss == 1.6.*
 --    hs-source-dirs: examples/real/NBody examples/real/NBody/Gloss lib
---    ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000
+--    ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000
 
 Executable dph-real-nbody
     Main-is:        MainBatch.hs
@@ -167,7 +167,7 @@ Executable dph-real-nbody
                            Solver.VectorNaive.Solver
                     Timing Points2D.Types Points2D.Generate
                     Batch.MainArgs Batch.Config
-    Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.1.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
+    Build-depends:  base == 4.6.*, vector == 0.9.*, random == 1.0.*, old-time == 1.0.*, containers == 0.5.*, dph-base == 0.6.*, dph-prim-par == 0.6.*, dph-lifted-vseg == 0.6.*, HUnit == 1.2.*
     hs-source-dirs: examples/real/NBody examples/real/NBody/Batch lib
-    ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fno-liberate-case -fsimpl-tick-factor=1000
+    ghc-options:    -eventlog -rtsopts -threaded -fllvm -Odph -package dph-lifted-vseg -fcpr-off -fsimpl-tick-factor=1000
 
index 337e28d..7aaddb8 100644 (file)
@@ -1,9 +1,12 @@
 
 module DPH.Core.Pretty 
         ( module DPH.Base.Pretty
+        , pprModGuts
         , pprTopBinds)
 where
 import DPH.Base.Pretty
+import HscTypes
+import Avail
 import CoreSyn
 import Type
 import Coercion
@@ -14,6 +17,35 @@ import DataCon
 import Literal
 import Id
 import Unique
+import qualified UniqFM as UFM
+
+-- Guts -----------------------------------------------------------------------
+pprModGuts :: ModGuts -> Doc
+pprModGuts guts
+ = vcat
+ [ text "Exports:" 
+        <+> ppr (mg_exports guts)
+ , empty
+
+ , text "VectInfo:"
+        <+> ppr (mg_vect_info guts)
+ , empty
+
+ , pprTopBinds $ mg_binds guts]
+
+
+-- | An AvailInfo carries an exported name.
+instance Pretty AvailInfo where
+ ppr aa
+  = case aa of
+        Avail n         -> ppr n
+        AvailTC n _     -> ppr n
+
+
+-- | The VectInfo maps names to their vectorised versions. 
+instance Pretty VectInfo where
+ ppr vi
+  = ppr $ UFM.eltsUFM (vectInfoVar vi)
 
 
 -- Top Binds ------------------------------------------------------------------
index 4af8089..0ec6a97 100644 (file)
@@ -11,10 +11,8 @@ import System.IO.Unsafe
 passDump :: String -> ModGuts -> CoreM ModGuts
 passDump name guts
  = unsafePerformIO
- $ do   let mdl = mg_module guts
-        let binds = mg_binds guts 
-
+ $ do
         writeFile ("dump." ++ name ++ ".hs")
-         $ render RenderIndent (pprTopBinds binds)
+         $ render RenderIndent (pprModGuts guts)
 
         return (return guts)
diff --git a/dph-plugin/DPH/Pass/Summon.hs b/dph-plugin/DPH/Pass/Summon.hs
new file mode 100644 (file)
index 0000000..aea1d1a
--- /dev/null
@@ -0,0 +1,151 @@
+
+-- 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. 
+--
+--   The summoner ignores GHC generated inliner heuristics (UnfoldingGuidance)
+--   as well as NOINLINE pragmas for bindings in the module being compiled.
+--
+--   It does respect loop breaker markers, as we can't summon into recursive
+--   functions indefinately. It also respects INLINE [N] phase numbers,
+--   because rewrite rules depend on these to fire.
+--
+
+module DPH.Pass.Summon
+        (passSummon)
+where
+import DPH.Core.Pretty
+import HscTypes
+import CoreSyn
+import CoreMonad
+import Avail
+import Data.Maybe
+import Data.Set                 (Set)
+import qualified UniqFM         as UFM
+import qualified Data.Set       as Set
+import Control.Monad
+import Debug.Trace
+
+-- Pass -----------------------------------------------------------------------
+passSummon :: ModGuts -> CoreM ModGuts
+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     
+                = catMaybes
+                $ map (UFM.lookupUFM (vectInfoVar $ mg_vect_info guts))
+                $ nsExported
+
+        -- Summon all of the vectorised things.
+        let summonMe    
+                = Set.fromList 
+                $ map snd 
+                $ nsExported_vect
+
+        tops'   <- mapM (summonTop summonMe tops) tops
+        return  $ guts { mg_binds = tops'}
+
+
+-- Top ------------------------------------------------------------------------
+-- | If some `CoreBind` is in the set, then summon all its parts.
+summonTop
+        :: Set CoreBndr -- ^ Summon into bindings with these binders.
+        -> [CoreBind]   -- ^ All the top-level bindings for this module.
+        -> CoreBind     -- ^ Binding to inspect
+        -> CoreM CoreBind
+
+summonTop bsSet tops bind
+ = case bind of
+        NonRec b x      
+         -> do  (b', x')        <- goSummon (b, x)
+                return $ NonRec b' x'
+
+        Rec bxs
+         -> do  bxs'            <- mapM goSummon bxs
+                return $ Rec bxs'
+ where
+        goSummon (b, x)
+         | Set.member b bsSet   = summon tops (b, x)
+         | otherwise            = return (b, x)
+
+
+-- Summon ---------------------------------------------------------------------
+-- | Inline everything we can find into this binding.
+summon  :: [CoreBind]            -- ^ All the top-level bindings for this module.
+        -> (CoreBndr, Expr CoreBndr)   -- ^ The binding to work on.
+        -> CoreM (CoreBndr, Expr CoreBndr)
+summon tops (b, xx)
+ = trace (renderIndent $ text "summoning " <> ppr b)
+ $ do   xx'     <- summonX tops xx
+        return  (b, xx')
+
+
+-- | Summon into an expression.
+summonX :: [CoreBind]
+        -> Expr CoreBndr
+        -> CoreM (Expr CoreBndr)
+summonX tops xx
+ = let down     = summonX tops
+   in case xx of
+        Var n   
+         -> trace (renderIndent $ text "look at " <> ppr n)
+         $  case lookupBind tops n of
+                Nothing -> return xx
+                Just x' -> summonX tops x'
+
+        Lit{}           -> return xx
+        App x arg       -> liftM2 App (down x)  (down arg)
+        Lam b   x       -> liftM2 Lam (return b)         (down x)
+        Let bnd x       -> liftM2 Let (summonB tops bnd) (down x)
+
+        Case x b t alts -> liftM4 Case  (down x)
+                                (return b) (return t) 
+                                (mapM (summonA tops) alts)
+
+        Cast x co       -> liftM2 Cast  (down x)   (return co)
+        Tick t x        -> liftM2 Tick  (return t) (down x)
+        Type t          -> return xx
+        Coercion co     -> return xx
+
+
+-- | Summon into an alternative.
+summonA :: [CoreBind] 
+        -> (AltCon, [CoreBndr], Expr CoreBndr)
+        -> CoreM (AltCon, [CoreBndr], Expr CoreBndr)
+
+summonA tops (con, bs, x)
+ = do   x'      <- summonX tops x
+        return  $ (con, bs, x')
+
+
+-- | Summon into a let-binding.
+summonB :: [CoreBind]
+        -> Bind CoreBndr
+        -> CoreM (Bind CoreBndr)
+
+summonB tops bb
+ = case bb of
+        NonRec b x      
+         -> liftM2 NonRec (return b) (summonX tops x)
+
+        Rec bxs
+         -> do  let (bs, xs)    = unzip bxs
+                xs'             <- mapM (summonX tops) xs
+                return          $ Rec $ zip bs xs
+
+
+lookupBind 
+        :: [CoreBind] 
+        -> CoreBndr
+        -> Maybe (Expr CoreBndr)
+lookupBind tops b
+ = case tops of
+        []      -> Nothing
+
+        (NonRec b' x : _)
+         | b == b'      -> Just x
+
+        _ : ts          -> lookupBind ts b
+
index 3bda3b8..dbfc8c2 100644 (file)
@@ -2,6 +2,7 @@
 module DPH.Pipeline 
         (vectoriserPipeline)
 where
+import DPH.Pass.Summon
 import DPH.Pass.Dump
 import GhcPlugins
 
@@ -50,7 +51,10 @@ vectoriserPipeline
                 , sm_inline     = True
                 , sm_case_case  = True } 
 
-   ,    CoreDoPluginPass "Dump" (passDump "2-closures")
+   ,    CoreDoPluginPass "Dump"   (passDump "2-closures")
+   ,    CoreDoPluginPass "Summon"  passSummon
+   ,    CoreDoPluginPass "Dump"   (passDump "2-closures-summoned")
+
 
         -- Inline PArray and PData combinators.
    ,    CoreDoSimplify 10