repa-plugin (empty) → 1.0.0.1
raw patch · 23 files changed
+3641/−0 lines, 23 filesdep +basedep +containersdep +ddc-basesetup-changed
Dependencies added: base, containers, ddc-base, ddc-core, ddc-core-flow, ddc-core-simpl, ghc, mtl
Files
- Data/Array/Repa/Plugin.hs +69/−0
- Data/Array/Repa/Plugin/FatName.hs +43/−0
- Data/Array/Repa/Plugin/GHC/Pretty.hs +287/−0
- Data/Array/Repa/Plugin/Pass/Dump.hs +22/−0
- Data/Array/Repa/Plugin/Pass/Lower.hs +270/−0
- Data/Array/Repa/Plugin/Pipeline.hs +62/−0
- Data/Array/Repa/Plugin/Primitives.hs +375/−0
- Data/Array/Repa/Plugin/ToDDC.hs +7/−0
- Data/Array/Repa/Plugin/ToDDC/Convert.hs +240/−0
- Data/Array/Repa/Plugin/ToDDC/Convert/Base.hs +81/−0
- Data/Array/Repa/Plugin/ToDDC/Convert/Type.hs +116/−0
- Data/Array/Repa/Plugin/ToDDC/Convert/Var.hs +76/−0
- Data/Array/Repa/Plugin/ToDDC/Detect.hs +321/−0
- Data/Array/Repa/Plugin/ToDDC/Detect/Base.hs +67/−0
- Data/Array/Repa/Plugin/ToDDC/Detect/Type.hs +219/−0
- Data/Array/Repa/Plugin/ToGHC.hs +482/−0
- Data/Array/Repa/Plugin/ToGHC/Prim.hs +238/−0
- Data/Array/Repa/Plugin/ToGHC/Type.hs +287/−0
- Data/Array/Repa/Plugin/ToGHC/Var.hs +57/−0
- Data/Array/Repa/Plugin/ToGHC/Wrap.hs +215/−0
- LICENSE +36/−0
- Setup.hs +2/−0
- repa-plugin.cabal +69/−0
+ Data/Array/Repa/Plugin.hs view
@@ -0,0 +1,69 @@++-- | This GHC plugin performs Data Flow Fusion as described in the following paper:+--+-- > Data Flow Fusion with Series Expressions in Haskell+-- > Ben Lippmeier, Manuel Chakravarty, Gabriele Keller, Amos Robinson.+-- > Haskell Sympoium, 2013.+--+-- <http://www.cse.unsw.edu.au/~benl/papers/flow/flow-Haskell2013.pdf>+--+-- The user-facing API is defined by the repa-series package.+--+-- To run the transform on a program do something like:+--+-- > ghc -O2 -fplugin=Data.Array.Repa.Plugin --make Main.hs+--+-- To see intermediate code as it is transformed, pass the 'dump' flag to the plugin.+--+-- > ghc -O2 -fplugin=Data.Array.Repa.Plugin -fplugin-opt Data.Array.Repa.Plugin:dump --make Main.hs+--+-- There is example code at: <http://code.ouroborus.net/repa/repa-head/repa-plugin/test/>+--+--+-- This is an EXPERIMENTAL implementation that some CURRENT LIMITATIONS:+--+-- * Only supports Series of element types @Int@ and (@Int@, @Int@). +-- You can't yet fuse code using the @Float@ type, or anything else.+--+-- * You can't use case-expressions in the worker functions passed+-- to combinators like @map@ and @fold@. +-- +-- * The plugin lacks support for many common list functions, +-- such as @append@.+--+-- * If your code cannot be fused then you may get an unhelpful error message.+-- +module Data.Array.Repa.Plugin + (plugin)+where+import Data.Array.Repa.Plugin.Pipeline+import GhcPlugins+import StaticFlags+import System.IO.Unsafe++-- | The Data Flow Fusion plugin.+plugin :: Plugin+plugin = defaultPlugin + { installCoreToDos = install }+++-- | Install a plugin into the GHC compilation pipeline.+install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]+install options todos+ = do + -- Initialize the staticflags so that we can pretty print core code.+ -- The pretty printers depend on static flags and will `error` if + -- we don't do this first.+ unsafePerformIO+ $ do addOpt "-dsuppress-all"+ addOpt "-dsuppress-idinfo"+ addOpt "-dsuppress-uniques"+ addOpt "-dppr-case-as-let"+ addOpt "-dppr-cols200"++ initStaticOpts+ return (return ())++ -- Replace the standard GHC pipeline with our one.+ return (vectoriserPipeline options todos)+
+ Data/Array/Repa/Plugin/FatName.hs view
@@ -0,0 +1,43 @@++module Data.Array.Repa.Plugin.FatName+ ( GhcName (..)+ , FatName (..))+where+import Data.Array.Repa.Plugin.GHC.Pretty ()++import DDC.Base.Pretty+import qualified DDC.Core.Flow.Prim as D++import qualified Var as G+import qualified Literal as G+import qualified TyCon as G+import qualified TypeRep as G+++data GhcName+ = GhcNameVar G.Var+ | GhcNameTyCon G.TyCon+ | GhcNameTyLit G.TyLit+ | GhcNameLiteral G.Literal+ | GhcNameIntU + deriving (Eq, Ord)++instance Pretty GhcName where+ ppr nn+ = case nn of+ GhcNameVar v -> text "VAR " <> ppr v+ GhcNameTyCon tc -> text "TYCON " <> ppr tc+ GhcNameTyLit tylit -> text "TYLIT " <> ppr tylit+ GhcNameLiteral lit -> text "LIT " <> ppr lit+ GhcNameIntU -> text "Int#"+++data FatName+ = FatName+ { fatNameGHC :: GhcName+ , fatNameDDC :: D.Name }+ deriving (Eq, Ord)++instance Pretty FatName where+ ppr (FatName _ name) = ppr name+
+ Data/Array/Repa/Plugin/GHC/Pretty.hs view
@@ -0,0 +1,287 @@++module Data.Array.Repa.Plugin.GHC.Pretty+ ( pprModGuts+ , pprTopBinds)+where+import DDC.Base.Pretty++import HscTypes+import Avail+import Type+import TypeRep+import TyCon+import CoreSyn+import Coercion+import Name+import DataCon+import Literal+import Var+import Id+import IdInfo+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 ------------------------------------------------------------------+pprTopBinds :: Pretty a => [Bind a] -> Doc+pprTopBinds binds+ = vcat $ map pprTopBind binds++pprTopBind :: Pretty a => Bind a -> Doc+pprTopBind (NonRec binder expr)+ = pprBinding (binder, expr) + <$$> empty++pprTopBind (Rec [])+ = text "Rec { }"++pprTopBind (Rec bb)+ = vcat + [ text "Rec {"+ , vcat [empty <$$> pprBinding b | b <- bb]+ , text "end Rec }"+ , empty ]+++-- Binding --------------------------------------------------------------------+pprBinding :: Pretty a => (a, Expr a) -> Doc+pprBinding (binder, x)+ = ppr binder + <+> breakWhen (not $ isSimpleX x)+ <+> equals <+> align (ppr x)+ +++-- Expr -----------------------------------------------------------------------+instance Pretty a => Pretty (Expr a) where+ pprPrec d xx+ = case xx of+ Var ident+ -> pprBound ident + <> text "{" <> ppr (idDetails ident) <> text "}"++ -- Discard types and coersions+ Type t -> text "@ " <> ppr t+ Coercion _ -> text "<C>"++ -- Literals.+ Lit ll -> ppr ll++ -- Suppress Casts completely.+ Cast x _co+ -> pprPrec d x++ -- Abstractions.+ Lam{}+ -> pprParen' (d > 2)+ $ let (bndrs, body) = collectBinders xx+ in text "\\" <> sep (map ppr bndrs)+ <> text "." + <> (nest 2 + $ (breakWhen $ not $ isSimpleX body)+ <> ppr body)++ -- Applications.+ App x1 x2+ -> pprParen' (d > 10)+ $ text "(" <> ppr x1+ <> nest 2 (breakWhen (not $ isSimpleX x2) + <> pprPrec 11 x2) <> text ")"++ -- Destructors.+ Case x1 _ _ [(con, binds, x2)]+ -> pprParen' (d > 2)+ $ text "let" + <+> (fill 12 (ppr con <+> hsep (map ppr binds)))+ <> breakWhen (not $ isSimpleX x1)+ <+> text "<-"+ <+> ppr x1+ <+> text "in"+ <$$> ppr x2++ Case x1 var _ alts+ -> pprParen' (d > 2)+ $ (nest 2 + $ text "case" <+> ppr x1 <+> text "of" + <+> ppr var+ <+> lbrace <> line+ <> vcat (punctuate semi $ map pprAlt alts))+ <> line <> rbrace++ -- Binding.+ Let (NonRec b x1) x2+ -> pprParen' (d > 2)+ $ text "let" + <+> fill 12 (ppr b)+ <+> equals + <+> ppr x1 + <+> text "in" + <$$> ppr x2++ Let (Rec bxs) x2+ -> pprParen' (d > 2)+ $ text "letrec {"+ <+> vcat [ fill 12 (ppr b)+ <+> equals+ <+> ppr x+ | (b, x) <- bxs]+ <+> text "} in"+ <$$> ppr x2++ _ -> text "DUNNO"+++-- Alt ------------------------------------------------------------------------+pprAlt :: Pretty a => (AltCon, [a], Expr a) -> Doc+pprAlt (con, binds, x)+ = ppr con <+> (hsep $ map ppr binds) + <+> nest 1 (line <> nest 3 (text "->" <+> ppr x))++instance Pretty AltCon where+ ppr con+ = case con of+ DataAlt con' -> ppr con'+ LitAlt lit -> ppr lit+ DEFAULT -> text "_"+++-- | Pretty print bound occurrences of an identifier+pprBound :: Id -> Doc+pprBound i+ -- Suppress uniqueids from primops, dictionary functions and data constructors+ -- These are unlikely to have conflicting base names.+ | isPrimOpId i || isDFunId i || isDataConWorkId i+ = ppr (idName i)++ | otherwise+ = ppr (idName i) <> text "_" <> text (show $ idUnique i)++++-- Literal --------------------------------------------------------------------+instance Pretty Literal where+ ppr _ = text "<LITERAL>"+++-- Type -----------------------------------------------------------------------+instance Pretty TyLit where+ ppr _ = text "<TYLIT>"++instance Pretty Type where+ ppr tt + = case tt of+ TyVarTy var -> ppr var+ AppTy t1 t2 -> ppr t1 <+> ppr t2+ TyConApp tc ks -> ppr tc <+> (hsep $ map ppr ks)+ FunTy t1 t2 -> ppr t1 <+> text "->" <+> ppr t2+ ForAllTy v t -> text "forall " <> ppr v <> text "." <> ppr t+ LitTy _ -> text "LitTy"+++-- Coercion -------------------------------------------------------------------+instance Pretty Coercion where+ ppr _ = empty+++-- Names ----------------------------------------------------------------------+instance Pretty CoreBndr where+ ppr bndr+ = ppr (idName bndr)+ <> text "_"+ <> text (show $ idUnique bndr)+++instance Pretty Name where+ ppr name+ = ppr (nameOccName name)++instance Pretty OccName where+ ppr occ+ = text (occNameString occ)++instance Pretty TyCon where+ ppr tc + = ppr (tyConName tc)+++instance Pretty IdDetails where+ ppr deets+ = case deets of+ VanillaId -> text "VanillaId"+ RecSelId{} -> text "RecSelId ..."+ DataConWorkId dc -> text "DataConWorkId " <> ppr dc+ DataConWrapId{} -> text "DataConWrapId ..."+ ClassOpId{} -> text "ClassOpId ..."+ PrimOpId{} -> text "PrimOpId ..."+ FCallId{} -> text "FCallId ..."+ TickBoxOpId{} -> text "TickBoxOpId ..."+ DFunId{} -> text "DFunId ..."++instance Pretty DataCon where+ ppr dc+ = text "DataCon {"+ <+> text "repType = " <+> ppr (dataConRepType dc)+ <+> text "}"+++-- Utils ----------------------------------------------------------------------+breakWhen :: Bool -> Doc+breakWhen True = line+breakWhen False = space+++isSimpleX :: Expr a -> Bool+isSimpleX xx+ = case xx of+ Var{} -> True+ Lit{} -> True+ App x1 x2 -> isSimpleX x1 && isAtomX x2+ Cast x1 _ -> isSimpleX x1+ _ -> False+++isAtomX :: Expr a -> Bool+isAtomX xx+ = case xx of+ Var{} -> True+ Lit{} -> True+ _ -> False+++parens' :: Doc -> Doc+parens' d = lparen <> nest 1 d <> rparen+++-- | Wrap a `Doc` in parens if the predicate is true.+pprParen' :: Bool -> Doc -> Doc+pprParen' b c+ = if b then parens' c+ else c
+ Data/Array/Repa/Plugin/Pass/Dump.hs view
@@ -0,0 +1,22 @@++module Data.Array.Repa.Plugin.Pass.Dump+ (passDump)+where+import Data.Array.Repa.Plugin.GHC.Pretty+import DDC.Base.Pretty+import HscTypes+import CoreMonad+import System.IO.Unsafe+import Control.Monad+++-- | Dump a module.+passDump :: [CommandLineOption] -> String -> ModGuts -> CoreM ModGuts+passDump options name guts+ = unsafePerformIO+ $ do+ when (elem "dump" options)+ $ writeFile ("dump." ++ name ++ ".hs")+ $ render RenderIndent (pprModGuts guts)++ return (return guts)
+ Data/Array/Repa/Plugin/Pass/Lower.hs view
@@ -0,0 +1,270 @@++module Data.Array.Repa.Plugin.Pass.Lower+ (passLower)+where+import Data.Array.Repa.Plugin.Primitives+import Data.Array.Repa.Plugin.ToDDC.Detect+import Data.Array.Repa.Plugin.ToDDC+import Data.Array.Repa.Plugin.ToGHC+import Data.Array.Repa.Plugin.GHC.Pretty+import DDC.Core.Exp++import qualified DDC.Core.Flow as Flow+import qualified DDC.Core.Flow.Profile as Flow+import qualified DDC.Core.Flow.Transform.Prep as Flow+import qualified DDC.Core.Flow.Transform.Slurp as Flow+import qualified DDC.Core.Flow.Transform.Schedule as Flow+import qualified DDC.Core.Flow.Transform.Extract as Flow+import qualified DDC.Core.Flow.Transform.Concretize as Flow+import qualified DDC.Core.Flow.Transform.Thread as Flow+import qualified DDC.Core.Flow.Transform.Wind as Flow++import qualified DDC.Core.Module as Core+import qualified DDC.Core.Check as Core+import qualified DDC.Core.Simplifier as Core+import qualified DDC.Core.Fragment as Core+import qualified DDC.Core.Transform.Namify as Core+import qualified DDC.Core.Transform.Flatten as Core+import qualified DDC.Core.Transform.Forward as Forward+import qualified DDC.Core.Transform.Thread as Core+import qualified DDC.Core.Transform.Reannotate as Core+import qualified DDC.Core.Transform.Snip as Snip+import qualified DDC.Core.Transform.Eta as Eta++import qualified HscTypes as G+import qualified CoreMonad as G+import qualified UniqSupply as G+import qualified DDC.Base.Pretty as D+import qualified Data.Map as Map+import System.IO.Unsafe+import Control.Monad.State.Strict+import Data.List+++-- | We use this unique when generating fresh names.+--+-- If this is not actually unique relative to the rest of the compiler+-- then we're completely screwed.+--+-- GHC doesn't seem to have an API to generate unique prefixes.+--+letsHopeThisIsUnique :: Char+letsHopeThisIsUnique = 's'+++-- | Run the lowering pass on this module.+passLower :: [G.CommandLineOption] -> String -> G.ModGuts -> G.CoreM G.ModGuts+passLower options name guts0+ = unsafePerformIO+ $ do+ -- Here's hoping this is really unique+ us <- G.mkSplitUniqSupply letsHopeThisIsUnique++ -- Decide whether to dump intermediate files+ let shouldDump = elem "dump" options+ let dump thing str = when shouldDump + $ writeFile ("dump." ++ name ++ "." ++ thing) str++ -- Input ------------------------------------------+ -- Dump the GHC core code that we start with.+ dump "01-ghc.hs" + $ D.renderIndent (pprModGuts guts0)+++ -- Primitives -------------------------------------+ -- Build a table of expressions to access our primitives.+ let (Just (primitives, guts), us2) + = G.initUs us (slurpPrimitives guts0)+++ -- Convert ----------------------------------------+ -- Convert the GHC Core module to Disciple Core.+ let (mm_dc, failsConvert) = convertModGuts guts++ dump "02-raw.dcf"+ $ D.renderIndent (D.ppr mm_dc)++ dump "02-raw.fails"+ $ D.renderIndent (D.vcat $ intersperse D.empty $ map D.ppr failsConvert)+++ -- Detect -----------------------------------------+ -- Detect flow operators and primitives.+ -- We also get a map of DDC names to GHC names+ let (mm_detect, names) = detectModule mm_dc++ dump "03-detect.dcf"+ $ D.renderIndent (D.ppr mm_detect)++ dump "03-detect.names"+ $ D.renderIndent (D.vcat $ map D.ppr $ Map.toList names)+++ -- Norm -------------------------------------------+ -- Eta expand everything so we have names for parameters.+ let etaConfig = Eta.configZero { Eta.configExpand = True }+ let mm_eta = Core.result $ Eta.etaModule etaConfig Flow.profile mm_detect++ dump "04-norm.1-eta.dcf"+ $ D.renderIndent (D.ppr mm_eta)++ -- A-normalize module for the Prep transform.+ let mkNamT = Core.makeNamifier Flow.freshT+ let mkNamX = Core.makeNamifier Flow.freshX++ -- Snip and flatten the code to create new let-bindings+ -- for flow combinators. This ensures all the flow combinators+ -- and workers are bound at the top-level of the function.+ let snipConfig = Snip.configZero { Snip.configSnipLetBody = True }+ let mm_snip' = Core.flatten $ Snip.snip snipConfig mm_eta+ let mm_snip = evalState (Core.namifyUnique mkNamT mkNamX mm_snip') 0++ dump "04-norm.dcf"+ $ D.renderIndent (D.ppr mm_snip)+++ -- Prep -------------------------------------------+ -- 1. Eta-expand worker functions passed to flow combinators.+ -- We also get back a map containing the types of parameters+ -- to worker functions.+ -- NOTE: We're not using the module result of prep now that + -- we have real eta-expansion.+ let (_, workerNameArgs) + = Flow.prepModule mm_snip++ -- 2. Move worker functions forward so they are directly+ -- applied to flow combinators.+ let isFloatable lts+ = case lts of+ LLet (BName n _) _ + | Just{} <- Map.lookup n workerNameArgs+ -> Forward.FloatForce+ _ -> Forward.FloatAllow++ let config = Forward.Config isFloatable False+ let result_forward = Forward.forwardModule Flow.profile config mm_snip+ + let mm_forward = Core.result result_forward++ dump "05-prep.1-forward.dcf"+ $ D.renderIndent (D.ppr mm_forward)++ -- 3. Create fresh names for anonymous binders.+ -- The lowering pass needs them all to have real names.+ let mm_namify = evalState (Core.namifyUnique mkNamT mkNamX mm_forward) 0++ dump "05-prep.2-namify.dcf"+ $ D.renderIndent (D.ppr mm_namify)++ -- 4. Type check add type annots on all binders.+ let mm_prep = checkFlowModule_ mm_namify++ dump "05-prep.3-check.dcf"+ $ D.renderIndent (D.ppr mm_prep)+++ -- Lower ------------------------------------------+ -- Slurp out flow processes from the preped module.+ let processes = Flow.slurpProcesses mm_prep++ -- Schedule processes into abstract loops.+ let procs = map Flow.scheduleProcess processes++ -- Extract concrete code from the abstract loops.+ let mm_lowered' = Flow.extractModule mm_prep procs+ let mm_lowered = evalState (Core.namifyUnique mkNamT mkNamX mm_lowered') 0++ dump "06-lowered.1-processes.txt"+ $ D.renderIndent (D.vcat $ intersperse D.empty $ map D.ppr $ processes)++ dump "06-lowered.dcf"+ $ D.renderIndent (D.ppr mm_lowered)+++ -- Concretize ------------------------------------+ -- Concretize rate variables.+ let mm_concrete = Flow.concretizeModule mm_lowered++ dump "07-concrete.dcf"+ $ D.renderIndent (D.ppr mm_concrete)+++ -- Wind ------------------------------------------+ -- Convert uses of the loop# and guard# combinator to real tail-recursive+ -- loops.+ let mm_wind = Core.result $ Forward.forwardModule Flow.profile + (Forward.Config (const Forward.FloatAllow) True)+ $ Core.result $ Forward.forwardModule Flow.profile + (Forward.Config (const Forward.FloatAllow) True)+ $ Core.result $ Forward.forwardModule Flow.profile + (Forward.Config (const Forward.FloatAllow) True)+ $ Core.result $ Forward.forwardModule Flow.profile + (Forward.Config (const Forward.FloatAllow) True)+ $ Flow.windModule mm_concrete++ dump "08-wind.dcf"+ $ D.renderIndent (D.ppr mm_wind)+++ -- Check -----------------------------------------+ -- Type check the module,+ -- the thread transform wants type annotations at each node.+ let mm_checked = checkFlowModule mm_wind++ dump "09-checked.dcf"+ $ D.renderIndent (D.ppr mm_checked)+++ -- Thread -----------------------------------------+ -- Thread the World# token through stateful functions in preparation+ -- for conversion back to GHC core.+ let mm_thread' = Core.thread Flow.threadConfig + (Core.profilePrimKinds Flow.profile)+ (Core.profilePrimTypes Flow.profile)+ mm_checked+ let mm_thread = evalState (Core.namifyUnique mkNamT mkNamX mm_thread') 0++ dump "10-threaded.dcf"+ $ D.renderIndent (D.ppr mm_thread)+++ -- Splice -----------------------------------------+ -- Splice the lowered functions back into the GHC core program.+ let guts' = G.initUs_ us2 + $ spliceModGuts primitives names mm_thread guts++ dump "11-spliced.fc"+ $ D.renderIndent (pprModGuts guts')++ return (return guts')+++-- | Type check a Core Flow module+checkFlowModule_ + :: Core.Module () Flow.Name + -> Core.Module () Flow.Name++checkFlowModule_ mm+ = Core.reannotate Core.annotTail + $ checkFlowModule mm+++-- | Type check a Core Flow module, producing type annotations on every node.+checkFlowModule + :: Core.Module () Flow.Name + -> Core.Module (Core.AnTEC () Flow.Name) Flow.Name++checkFlowModule mm+ = let result = Core.checkModule + (Core.configOfProfile Flow.profile)+ mm+ in case result of+ Right mm' -> mm'+ Left err+ -> error $ D.renderIndent $ D.indent 8 $ D.vcat+ [ D.empty+ , D.text "repa-plugin:"+ , D.indent 2 + $ D.vcat [ D.text "Type error in generated code"+ , D.ppr err ] ]+
+ Data/Array/Repa/Plugin/Pipeline.hs view
@@ -0,0 +1,62 @@++module Data.Array.Repa.Plugin.Pipeline + (vectoriserPipeline)+where+import Data.Array.Repa.Plugin.Pass.Dump+import Data.Array.Repa.Plugin.Pass.Lower+import GhcPlugins+++-- | Our vectoriser pipeline.+--+-- Inject the lowering transform just after the first simplification stage,+-- or add a simplification and lowering at the end if there is none.+--+vectoriserPipeline :: [CommandLineOption] -> [CoreToDo] -> [CoreToDo]+vectoriserPipeline options todos+ -- If an initial simplifier exists, lower straight afterwards+ | (before, (simp:after)) <- break isPreSimplifier todos+ = before ++ [simp] ++ todoLower options ++ after ++ todoDump options++ -- There is no simplifier (eg not compiled with -O)+ -- So add our own at the end+ | otherwise+ = todos ++ todoPreSimplifier ++ todoLower options ++ todoDump options+++-- Do our own pre simplification.+todoPreSimplifier :: [CoreToDo]+todoPreSimplifier+ = [ CoreDoSimplify 10+ SimplMode + { sm_names = ["Vectorise", "PreSimplify"]+ , sm_phase = InitialPhase+ , sm_rules = True+ , sm_eta_expand = True+ , sm_inline = False+ , sm_case_case = False } ]+++-- Dump the simplified code,+-- then lower the series expressions in the code.+todoLower :: [CommandLineOption] -> [CoreToDo]+todoLower options+ = [ CoreDoPluginPass "Dump" (passDump options "1-dump")+ , CoreDoPluginPass "Lower" (passLower options "2-lower") ]+++-- Dump the final result, after GHC optimises the lowered code+todoDump :: [CommandLineOption] -> [CoreToDo]+todoDump options+ = [ CoreDoPluginPass "Dump" (passDump options "3-final") ]+++-- | Check if a `CoreToDo` looks like the pre-simplifier.+isPreSimplifier :: CoreToDo -> Bool+isPreSimplifier c+ = case c of+ CoreDoSimplify _ SimplMode { sm_phase = InitialPhase }+ -> True+ _ -> False++
+ Data/Array/Repa/Plugin/Primitives.hs view
@@ -0,0 +1,375 @@++module Data.Array.Repa.Plugin.Primitives+ ( Primitives (..)+ , slurpPrimitives)+where+import Data.Array.Repa.Plugin.ToGHC.Var+import Data.List+import Data.Maybe+import Control.Monad++import qualified HscTypes as G+import qualified CoreSyn as G+import qualified MkCore as G+import qualified DataCon as G+import qualified TyCon as G+import qualified Type as G+import qualified Var as G+import qualified OccName as Occ+import qualified Name as Name++import UniqSupply as G+import qualified UniqSet as US+++-------------------------------------------------------------------------------+-- | Table of GHC core expressions to use to invoke the primitives+-- needed by the lowering transform.+data Primitives+ = Primitives+ { prim_Series :: !G.Type+ , prim_Vector :: !G.Type+ , prim_Ref :: !G.Type++ -- Arith Int+ , prim_addInt :: (G.CoreExpr, G.Type)+ , prim_subInt :: (G.CoreExpr, G.Type)+ , prim_mulInt :: (G.CoreExpr, G.Type)+ , prim_divInt :: (G.CoreExpr, G.Type)+ , prim_modInt :: (G.CoreExpr, G.Type)+ , prim_remInt :: (G.CoreExpr, G.Type)++ -- Eq Int+ , prim_eqInt :: (G.CoreExpr, G.Type)+ , prim_neqInt :: (G.CoreExpr, G.Type)+ , prim_gtInt :: (G.CoreExpr, G.Type)+ , prim_geInt :: (G.CoreExpr, G.Type)+ , prim_ltInt :: (G.CoreExpr, G.Type)+ , prim_leInt :: (G.CoreExpr, G.Type)++ -- Ref Int+ , prim_newRefInt :: (G.CoreExpr, G.Type)+ , prim_readRefInt :: (G.CoreExpr, G.Type)+ , prim_writeRefInt :: (G.CoreExpr, G.Type)+ , prim_newRefInt_T2 :: (G.CoreExpr, G.Type)+ , prim_readRefInt_T2 :: (G.CoreExpr, G.Type)+ , prim_writeRefInt_T2 :: (G.CoreExpr, G.Type)++ -- Vector Int+ , prim_newVectorInt :: (G.CoreExpr, G.Type)+ , prim_readVectorInt :: (G.CoreExpr, G.Type)+ , prim_writeVectorInt :: (G.CoreExpr, G.Type)+ , prim_sliceVectorInt :: (G.CoreExpr, G.Type)++ -- Loop+ , prim_loop :: (G.CoreExpr, G.Type)+ , prim_guard :: (G.CoreExpr, G.Type)+ , prim_rateOfSeries :: (G.CoreExpr, G.Type)+ , prim_nextInt :: (G.CoreExpr, G.Type)+ , prim_nextInt_T2 :: (G.CoreExpr, G.Type)+ }+++-- | Names of all the primitive types.+-- These should match the field names of `Primitives` above.+_primitive_types+ = [ "Series"+ , "Vector"+ , "Ref" ]+++-- | Names of all the primitive operators.+-- These should match the field names of `Primitives` above.+primitive_ops+ = -- Arith Int+ [ "prim_addInt"+ , "prim_subInt"+ , "prim_mulInt"+ , "prim_divInt"+ , "prim_modInt"+ , "prim_remInt"++ -- Eq Int+ , "prim_eqInt"+ , "prim_neqInt"+ , "prim_gtInt"+ , "prim_geInt"+ , "prim_ltInt"+ , "prim_leInt"++ -- Ref Int+ , "prim_newRefInt"+ , "prim_readRefInt"+ , "prim_writeRefInt"+ -- Ref (Int,Int)+ , "prim_newRefInt_T2"+ , "prim_readRefInt_T2"+ , "prim_writeRefInt_T2"++ -- Vector Int+ , "prim_newVectorInt"+ , "prim_readVectorInt"+ , "prim_writeVectorInt"+ , "prim_sliceVectorInt"++ -- Loop+ , "prim_loop"+ , "prim_guard"+ , "prim_rateOfSeries"+ , "prim_nextInt" + , "prim_nextInt_T2" ]+++-------------------------------------------------------------------------------+-- | Try to slurp the primitive table from a GHC module.+--+-- The table should be in a top-level binding named "repa_primitives".+-- If we find it, then we add more top-level functions to the module +-- that select the individual primitives, then build a table of expressions+-- that can be used to access them.+--+slurpPrimitives + :: G.ModGuts + -> UniqSM (Maybe (Primitives, G.ModGuts))++slurpPrimitives guts+ | Just vTable <- listToMaybe + $ mapMaybe findTableFromTopBind + $ G.mg_binds guts+ = do + Just (prims, bsMoar) <- makeTable vTable++ let hackedGuts + = guts + { G.mg_binds + = insertAfterTable bsMoar + $ G.mg_binds guts+ + , G.mg_used_names + = US.addListToUniqSet (G.mg_used_names guts)+ $ [G.varName b | G.NonRec b _ <- bsMoar ]}++ return $ Just (prims, hackedGuts)++ | otherwise+ = return Nothing+ ++-------------------------------------------------------------------------------+-- | Try to find the primitive table in this top level binding.+findTableFromTopBind :: G.CoreBind -> Maybe G.Var+findTableFromTopBind bnd+ = case bnd of+ G.Rec{} -> Nothing+ G.NonRec b _ -> findTableFromBinding b+++-- | Try to find the primitive table in this top level binding.+-- It needs to be named "repa_primitives"+findTableFromBinding :: G.CoreBndr -> Maybe G.Var+findTableFromBinding b+ | strName <- Occ.occNameString + $ Name.nameOccName + $ G.varName b+ , strName == "repa_primitives"+ = Just b++ | otherwise+ = Nothing+++-------------------------------------------------------------------------------+-- | Insert some top-level bindings after the primitive table.+insertAfterTable :: [G.CoreBind] -> [G.CoreBind] -> [G.CoreBind]+insertAfterTable bsMore bs+ = case bs of+ [] + -> bs+ + bb@G.Rec{} : bs' + -> bb : insertAfterTable bsMore bs'+ + bb@(G.NonRec b _) : bs'+ | isJust $ findTableFromBinding b+ -> bb : bsMore ++ bs'++ | otherwise+ -> bb : insertAfterTable bsMore bs'+++-------------------------------------------------------------------------------+-- | Create top-level projection functions based on the primitive table+-- attached to this variable.+makeTable + :: G.Var + -> UniqSM (Maybe (Primitives, [G.CoreBind]))++makeTable v+ | t <- G.varType v+ , Just tc <- G.tyConAppTyCon_maybe t+ , G.isAlgTyCon tc+ , G.DataTyCon [dc] False <- G.algTyConRhs tc+ = do+ let labels+ = G.dataConFieldLabels dc++ -- Load types from their proxy fields.+ let Just tySeries + = liftM (G.dataConFieldType dc)+ $ find (\n -> stringOfName n == "prim_Series") labels++ let Just tyVector + = liftM (G.dataConFieldType dc)+ $ find (\n -> stringOfName n == "prim_Vector") labels++ let Just tyRef+ = liftM (G.dataConFieldType dc)+ $ find (\n -> stringOfName n == "prim_Ref") labels++ -- Build table of selectors for all the operators.+ (bs, selectors) <- makeSelectors v primitive_ops+ let get name+ = let Just r = lookup name selectors+ in r++ let table + = Primitives+ { prim_Series = tySeries+ , prim_Vector = tyVector+ , prim_Ref = tyRef++ -- Arith Int+ , prim_addInt = get "prim_addInt"+ , prim_subInt = get "prim_subInt"+ , prim_mulInt = get "prim_mulInt"+ , prim_divInt = get "prim_divInt"+ , prim_modInt = get "prim_modInt"+ , prim_remInt = get "prim_remInt"++ -- Eq Int+ , prim_eqInt = get "prim_eqInt"+ , prim_neqInt = get "prim_neqInt"+ , prim_gtInt = get "prim_gtInt"+ , prim_geInt = get "prim_geInt"+ , prim_ltInt = get "prim_ltInt"+ , prim_leInt = get "prim_leInt"++ -- Ref Int+ , prim_newRefInt = get "prim_newRefInt"+ , prim_readRefInt = get "prim_readRefInt"+ , prim_writeRefInt = get "prim_writeRefInt"+ -- Ref (Int,Int)+ , prim_newRefInt_T2 = get "prim_newRefInt_T2"+ , prim_readRefInt_T2 = get "prim_readRefInt_T2"+ , prim_writeRefInt_T2 = get "prim_writeRefInt_T2"++ -- Vector Int+ , prim_newVectorInt = get "prim_newVectorInt"+ , prim_readVectorInt = get "prim_readVectorInt"+ , prim_writeVectorInt = get "prim_writeVectorInt"+ , prim_sliceVectorInt = get "prim_sliceVectorInt"++ -- Loop+ , prim_rateOfSeries = get "prim_rateOfSeries" + , prim_loop = get "prim_loop"+ , prim_guard = get "prim_guard"+ , prim_nextInt = get "prim_nextInt"+ , prim_nextInt_T2 = get "prim_nextInt_T2" }+++ return $ Just (table, bs)++ | otherwise+ = return Nothing+++-------------------------------------------------------------------------------+-- | Make the selector table.+makeSelectors+ :: G.Var -- ^ Core variable bound to our primitive table.+ -> [String] -- ^ Names of all the primtiives.+ -> UniqSM ([G.CoreBind], [(String, (G.CoreExpr, G.Type))])++makeSelectors v strs+ = do+ (bs, xts) <- liftM unzip+ $ mapM (makeSelector v) strs++ return $ (bs, zip strs xts)+++-------------------------------------------------------------------------------+-- | Build a CoreExpr that produces the primtive with the given name.+makeSelector+ :: G.Var -- ^ Core variable bound to our primtiive table.+ -> String -- ^ Name of the primitive we want.+ -> UniqSM (G.CoreBind, (G.CoreExpr, G.Type))++makeSelector v strField+ | t <- G.varType v+ , Just tc <- G.tyConAppTyCon_maybe t+ , G.isAlgTyCon tc+ , G.DataTyCon [dc] False <- G.algTyConRhs tc+ , labels <- G.dataConFieldLabels dc+ , Just field <- find (\n -> stringOfName n == strField) labels+ = makeSelector' dc field (G.Var v) (G.varType v)++ | otherwise+ = error $ "repa-plugin.makeSelector: can't find primitive named " ++ strField+++makeSelector'+ :: G.DataCon -- ^ Data constructor for the primitive table.+ -> G.FieldLabel -- ^ Name of the field to project out.+ -> G.CoreExpr -- ^ Expression to produce the table.+ -> G.Type -- ^ Type of the table.+ -> UniqSM (G.CoreBind, (G.CoreExpr, G.Type))++makeSelector' dc labelWanted xTable tTable+ = do + -- Make binders to match all fields,+ -- including one for the field we want.+ (bsAll, vWanted) <- makeFieldBinders dc labelWanted++ -- The type of the wanted field.+ let tResult = G.dataConFieldType dc labelWanted++ -- Top level name for this primitive.+ vPrim <- newDummyExportedVar (stringOfName labelWanted) tResult+ + let bPrim = G.NonRec vPrim + $ G.mkWildCase xTable tTable tResult+ [ (G.DataAlt dc, bsAll, G.Var vWanted)]++ return (bPrim, (G.Var vPrim, tResult))+ ++-- | Make a sequence of binders +makeFieldBinders + :: G.DataCon -- ^ Data constructor for the primtiive table.+ -> G.FieldLabel -- ^ The field we want to project out.+ -> UniqSM ([G.Var], G.Var) -- ^ All binders, and the one for our desired field.++makeFieldBinders dc labelWanted+ = do let tWanted = G.dataConFieldType dc labelWanted+ vWanted <- newDummyVar "wanted" tWanted+ let bsAll = go vWanted (G.dataConFieldLabels dc)+ return (bsAll, vWanted)++ where go _ [] = []+ go vWanted (l:ls)+ | l == labelWanted + = vWanted+ : go vWanted ls++ | otherwise + = (G.mkWildValBinder $ G.dataConFieldType dc l)+ : go vWanted ls+++-- Utils ----------------------------------------------------------------------+-- | Convert a GHC name to a string+stringOfName :: Name.Name -> String+stringOfName name+ = Occ.occNameString $ Name.nameOccName name+
+ Data/Array/Repa/Plugin/ToDDC.hs view
@@ -0,0 +1,7 @@++module Data.Array.Repa.Plugin.ToDDC+ ( convertModGuts+ , detectModule)+where+import Data.Array.Repa.Plugin.ToDDC.Convert+import Data.Array.Repa.Plugin.ToDDC.Detect
+ Data/Array/Repa/Plugin/ToDDC/Convert.hs view
@@ -0,0 +1,240 @@++module Data.Array.Repa.Plugin.ToDDC.Convert+ (convertModGuts)+where+import Data.Array.Repa.Plugin.ToDDC.Convert.Base+import Data.Array.Repa.Plugin.ToDDC.Convert.Type+import Data.Array.Repa.Plugin.ToDDC.Convert.Var+import Data.Array.Repa.Plugin.FatName+import Control.Monad+import Data.Either+import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Set as Set++import qualified DDC.Core.Exp as D+import qualified DDC.Core.Module as D+import qualified DDC.Core.Compounds as D+import qualified DDC.Core.Flow as D+import qualified DDC.Core.Collect as D+import qualified DDC.Type.Env as D++import qualified CoreSyn as G+import qualified DataCon as G+import qualified HscTypes as G+import qualified TyCon as G+import qualified Type as G+import qualified Var as G+++-------------------------------------------------------------------------------+-- | Convert a GHC module to Disciple Core Flow.+--+-- This is a raw conversion of the AST. We still need to detect the primitive+-- flow operators before we can run the lowering pass.+--+-- We get back a Disciple Core Flow module containing all the top-level+-- bindings that we could convert, and a list of reasons why conversion +-- for the other bindings failed.+--+convertModGuts + :: G.ModGuts + -> (D.Module () FatName, [Fail])++convertModGuts guts+ = let (bnds', fails) + = convertTopBinds $ G.mg_binds guts+ body = D.xLets () bnds' (D.xUnit ())++ -- Find the free variables in the module body+ freeX = D.freeX D.empty body++ -- And add them all to the import types+ importT = foldl (insertImport convertType) Map.empty+ $ Set.toList freeX++ -- Then find the type constructors mentioned in the imports+ freeT = Set.unions (map (D.supportTyCon . D.support D.empty D.empty . snd . snd) + $ Map.toList importT)+ -- And add them to the import kinds+ importK = foldl (insertImport convertKind) Map.empty+ $ Set.toList freeT++ mm' = D.ModuleCore+ { D.moduleName = D.ModuleName ["Flow"]+ , D.moduleExportKinds = Map.empty+ , D.moduleExportTypes = Map.empty+ , D.moduleImportKinds = importK+ , D.moduleImportTypes = importT+ , D.moduleBody = body }++ in (mm', fails)+++-- | Convert a type/kind and add it to the import map, if conversion succeeds.+insertImport :: (G.Type -> Either Fail (D.Type FatName))+ -> Map FatName (D.QualName FatName, D.Type FatName)+ -> D.Bound FatName+ -> Map FatName (D.QualName FatName, D.Type FatName)+insertImport c m bound+ | D.UName n@(FatName ghc _) <- bound+ , GhcNameVar v <- ghc+ = ins n (c $ G.varType v)++ | D.UName n@(FatName ghc _) <- bound+ , GhcNameTyCon tc <- ghc+ = ins n (c $ G.tyConKind tc)++ | otherwise+ = m+ where+ ins _ (Left _) = m+ ins n (Right t) = Map.insert n (D.QualName (D.ModuleName []) n, t) m+++-- Bindings -------------------------------------------------------------------+-- | Convert top-level bindings.+convertTopBinds + :: [G.CoreBind] + -> ([D.Lets () FatName], [Fail])++convertTopBinds bnds+ = let results = map convertTopBind bnds+ (fails, bnds') = partitionEithers results+ in (bnds', fails)+++-- | Convert a possibly recursive top-level binding.+convertTopBind + :: G.CoreBind + -> Either Fail (D.Lets () FatName)++convertTopBind bnd+ = case bnd of+ G.NonRec b x + -> case convertBinding (b, x) of+ Left fails -> Left $ FailInBinding b fails+ Right (b', x') -> return $ D.LLet b' x'++ G.Rec bxs+ -> do ns' <- mapM (convertFatName.fst) bxs+ ts' <- mapM (convertVarType.fst) bxs+ xs' <- mapM (convertExpr .snd) bxs+ let bxs' = zip (zipWith D.BName ns' ts') xs'+ return $ D.LRec bxs'++++-- | Convert a single binding.+ -- TODO: select bindings to lower more generally.+convertBinding + :: (G.CoreBndr, G.CoreExpr)+ -> Either Fail (D.Bind FatName, D.Exp () FatName)++convertBinding (b, x)+ = do n <- convertVarName b+ case n of+ D.NameVar str+ | isPrefixOf "lower" str+ -> do x' <- convertExpr x+ fn' <- convertFatName b+ t' <- convertVarType b+ return $ (D.BName fn' t', x')++ | otherwise+ -> Left FailNotMarked++ _ -> Left (FailDodgyTopLevelBindingName n)+++-- Expr -----------------------------------------------------------------------+-- | Slurp an expression.+convertExpr :: G.CoreExpr + -> Either Fail (D.Exp () FatName)++convertExpr xx+ = case xx of+ G.Var v+ -> do name' <- convertFatName v+ return $ D.XVar () (D.UName name')++ G.Lit lit+ -> do lit' <- convertLiteral lit+ return $ D.XCon () lit'++ G.App x1 x2+ -> do x1' <- convertExpr x1+ x2' <- convertExpr x2+ return $ D.XApp () x1' x2'++ G.Lam b x+ -> do x' <- convertExpr x+ n' <- convertFatName b+ t' <- convertVarType b+ return $ D.XLam () (D.BName n' t') x'++ G.Let (G.NonRec b x1) x2+ -> do n' <- convertFatName b+ t' <- convertVarType b+ x1' <- convertExpr x1+ x2' <- convertExpr x2+ return $ D.XLet () (D.LLet (D.BName n' t') x1') x2'++ G.Let (G.Rec bxs) x+ -> do ns' <- mapM (convertFatName.fst) bxs+ ts' <- mapM (convertVarType.fst) bxs+ xs' <- mapM (convertExpr .snd) bxs+ let bxs' = zip (zipWith D.BName ns' ts') xs'+ x' <- convertExpr x+ return $ D.XLet () (D.LRec bxs') x'++ -- Simple case expressions with just DataAlts+ G.Case x b _tres alts+ -> do b' <- convertFatName b+ t' <- convertVarType b+ x' <- convertExpr x+ alts' <- mapM convertAlt alts++ -- Case+ return $ D.XLet () (D.LLet (D.BName b' t') x')+ $ D.XCase () (D.XVar () (D.UName b')) alts'++ -- We can't represent type casts/+ -- Actually, we require these for series of tuples. + G.Cast x _ -> convertExpr x + -- TODO: We're just ditching casts.++ -- Just ditch tick nodes, we probably don't need them.+ G.Tick _ x -> convertExpr x++ -- Type arguments.+ G.Type t -> liftM D.XType (convertType t)++ -- Cannot convert coercions.+ G.Coercion{} -> Left FailNoCoercions+++-- Convert a case alternative+convertAlt :: G.Alt G.Var -> Either Fail (D.Alt () FatName)+convertAlt (con, bs, x)+ = do ns' <- mapM convertFatName bs+ ts' <- mapM convertVarType bs+ x' <- convertExpr x+ case con of+ G.DEFAULT + -> return $ D.AAlt D.PDefault x'++ G.DataAlt dc+ -> do nm <- convertName $ G.dataConName dc+ ty <- convertType $ G.dataConRepType dc+ let binds = zipWith D.BName ns' ts'+ let fat = FatName (GhcNameTyCon $ G.promoteDataCon dc) nm++ -- It must be algebraic, since we are casing on it.+ let pat = D.PData (D.mkDaConAlg fat ty) binds+ return $ D.AAlt pat x'++ G.LitAlt _ + -> Left FailUnhandledCase+
+ Data/Array/Repa/Plugin/ToDDC/Convert/Base.hs view
@@ -0,0 +1,81 @@++module Data.Array.Repa.Plugin.ToDDC.Convert.Base+ (Fail (..))+where+import DDC.Base.Pretty+import qualified DDC.Core.Flow as D++import qualified Literal as G+import qualified Var as G+import qualified OccName as Occ+import qualified Name as Name++-- | A reason why we didn't convert a GHC Core thing to Disciple Core.+data Fail+ -- Atomic Failures ------------+ -- | Top level binding was not marked for conversion.+ = FailNotMarked++ -- | Cannot convert numeric type literals.+ | FailNoNumericTypeLiterals++ -- | Cannot convert recursive binding groups.+ | FailNoRecursion [G.Var]++ -- | Cannot convert type casts.+ | FailNoCasts++ -- | Cannot convert coercions.+ | FailNoCoercions++ -- | Unhandled literal value+ | FailUnhandledLiteral G.Literal++ -- | Case expressions not handled yet.+ | FailUnhandledCase++ -- | Name read from GHC Core is empty.+ | FailEmptyName++ -- | Dodgy top-level binding name.+ | FailDodgyTopLevelBindingName D.Name++ -- Fail combinators -----------+ -- | Failure in a top-level binding.+ | FailInBinding G.Var Fail+++instance Pretty Fail where+ ppr FailNotMarked+ = text "Top level binding not marked for conversion."++ ppr FailNoNumericTypeLiterals+ = text "Cannot convert numeric type literals."++ ppr (FailNoRecursion _)+ = text "Cannot convert recursive binding groups."++ ppr FailNoCasts+ = text "Cannnot convert type casts."++ ppr FailNoCoercions+ = text "Cannot convert coercions."++ ppr (FailUnhandledLiteral _)+ = text "Unhandled literal value."++ ppr (FailUnhandledCase)+ = text "Unhandled case expresson."++ ppr FailEmptyName+ = text "Empty name in GHC Core program."++ ppr (FailDodgyTopLevelBindingName _)+ = text "Dodgy top level binding name."++ ppr (FailInBinding v fails)+ = vcat [ text "In binding "+ <> text "'" + <> (text $ Occ.occNameString $ Name.occName $ G.varName v)+ <> text "'"+ , ppr fails]
+ Data/Array/Repa/Plugin/ToDDC/Convert/Type.hs view
@@ -0,0 +1,116 @@++module Data.Array.Repa.Plugin.ToDDC.Convert.Type+ ( convertVarType+ , convertType+ , convertKind)+where+import Data.Array.Repa.Plugin.ToDDC.Convert.Base+import Data.Array.Repa.Plugin.ToDDC.Convert.Var+import Data.Array.Repa.Plugin.FatName++import qualified DDC.Core.Exp as D+import qualified DDC.Core.Compounds as D+import qualified DDC.Core.Flow as D++import qualified Type as G+import qualified TypeRep as G+import qualified TyCon as G+import qualified Var as G+import qualified FastString as G+++-- Variables ------------------------------------------------------------------+-- | Convert a type from a GHC variable.+convertVarType :: G.Var -> Either Fail (D.Type FatName)+convertVarType v+ = convertType $ G.varType v+++-- Type -----------------------------------------------------------------------+-- | Convert a type.+convertType :: G.Type -> Either Fail (D.Type FatName)+convertType tt+ = case tt of+ G.TyVarTy v+ -> do v' <- convertFatName v+ return $ D.TVar (D.UName v')++ G.AppTy t1 t2+ -> do t1' <- convertType t1+ t2' <- convertType t2+ return $ D.TApp t1' t2'++ G.TyConApp tc ts+ -> do tc' <- convertTyCon tc+ ts' <- mapM convertType ts+ return $ D.tApps (D.TCon tc') ts'++ G.FunTy t1 t2+ -> do t1' <- convertType t1+ t2' <- convertType t2+ return $ D.tFun t1' t2'++ G.ForAllTy v t+ -> do v' <- convertFatName v+ t' <- convertType t+ return $ D.TForall (D.BName v' D.kData) t'++ G.LitTy (G.NumTyLit _) + -> error "repa-plugin.slurpType: numeric type literals not handled."++ G.LitTy tyLit@(G.StrTyLit fs)+ -> return $ D.TVar (D.UName (FatName (GhcNameTyLit tyLit)+ (D.NameCon (G.unpackFS fs))))+++-- TyCon ----------------------------------------------------------------------+-- | Convert a tycon.+convertTyCon :: G.TyCon -> Either Fail (D.TyCon FatName)+convertTyCon tc+ | G.isFunTyCon tc+ = return $ D.TyConSpec D.TcConFun++ | otherwise+ = do name' <- convertName $ G.tyConName tc+ return $ D.TyConBound+ (D.UName (FatName (GhcNameTyCon tc) name'))+ (D.kData) -- TODO: Get real kind of tycon.+++-- Kind -----------------------------------------------------------------------+-- | Convert a kind: particularly function arrows are changed to kind arrows.+convertKind :: G.Type -> Either Fail (D.Type FatName)+convertKind tt+ = case tt of+ G.TyVarTy v+ -> do v' <- convertFatName v+ return $ D.TVar (D.UName v')++ G.AppTy t1 t2+ -> do t1' <- convertKind t1+ t2' <- convertKind t2+ return $ D.TApp t1' t2'++ G.TyConApp tc ts+ -> do tc' <- convertTyCon tc+ ts' <- mapM convertKind ts+ return $ D.tApps (D.TCon tc') ts'++ G.FunTy t1 t2+ -> do t1' <- convertKind t1+ t2' <- convertKind t2+ return $ D.kFun t1' t2'++ G.ForAllTy v t+ -> do v' <- convertFatName v+ t' <- convertKind t+ return $ D.TForall (D.BName v' D.kData) t'++ G.LitTy (G.NumTyLit _) + -> error "repa-plugin.convertKind: numeric type literals not handled."++ G.LitTy tyLit@(G.StrTyLit fs)+ -> return $ D.TVar (D.UName (FatName (GhcNameTyLit tyLit)+ (D.NameCon (G.unpackFS fs))))++
+ Data/Array/Repa/Plugin/ToDDC/Convert/Var.hs view
@@ -0,0 +1,76 @@++module Data.Array.Repa.Plugin.ToDDC.Convert.Var+ ( convertFatName+ , convertVarName+ , convertName+ , convertLiteral)+where+import Data.Array.Repa.Plugin.ToDDC.Convert.Base+import Data.Array.Repa.Plugin.FatName+import DDC.Base.Pretty+import Data.Char++import qualified DDC.Core.Exp as D+import qualified DDC.Core.Compounds as D+import qualified DDC.Core.Flow as D++import qualified Type as G+import qualified Var as G+import qualified OccName as OccName+import qualified Name as Name+import qualified Literal as G+++-- Names ----------------------------------------------------------------------+-- | Convert a FatName from a GHC variable.+convertFatName :: G.Var -> Either Fail FatName+convertFatName var+ = do vn <- convertVarName var+ return $ FatName (GhcNameVar var) vn+++-- | Convert a printable DDC name from a GHC variable.+convertVarName :: G.Var -> Either Fail D.Name+convertVarName var+ = convertName (G.varName var)+++-- | Convert a DDC name from a GHC name.+convertName :: Name.Name -> Either Fail D.Name+convertName name+ = let baseName = OccName.occNameString+ $ Name.nameOccName name++ unique = show $ Name.nameUnique name+ str = renderPlain (text baseName <> text "_" <> text unique)++ in case baseName of+ [] -> Left FailEmptyName+ c : _ + | isUpper c -> return $ D.NameCon str+ | otherwise -> return $ D.NameVar str+++-- Literals -------------------------------------------------------------------+-- | Slurp a literal.+convertLiteral + :: G.Literal + -> Either Fail (D.DaCon FatName)++convertLiteral lit+ = case lit of+ G.MachInt i + -> let fn = (FatName (GhcNameLiteral lit) (D.NameLitInt i))+ in return $ D.mkDaConAlg fn tIntU'++ -- TODO: convert the rest of the literals.+ _ -> Left (FailUnhandledLiteral lit)+++tIntU' = D.TCon + $ D.TyConBound + (D.UPrim (FatName GhcNameIntU + (D.NamePrimTyCon D.PrimTyConInt))+ D.kData)+ D.kData+
+ Data/Array/Repa/Plugin/ToDDC/Detect.hs view
@@ -0,0 +1,321 @@++module Data.Array.Repa.Plugin.ToDDC.Detect+ (detectModule)+where+import Data.Array.Repa.Plugin.FatName+import Data.Array.Repa.Plugin.ToDDC.Detect.Base+import Data.Array.Repa.Plugin.ToDDC.Detect.Type ()++import DDC.Core.Module+import DDC.Core.Collect+import DDC.Type.Env+import DDC.Core.Flow+import DDC.Core.Flow.Exp+import DDC.Core.Flow.Prim+import DDC.Core.Flow.Compounds+import DDC.Core.Transform.Annotate+import DDC.Core.Transform.Deannotate++import Control.Monad.State.Strict++import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.Set as Set+import Data.List+++detectModule + :: Module () FatName + -> (Module () Name, Map Name GhcName)++detectModule mm+ = let (mm', state') = runState (detect mm) $ zeroState+ in (mm', stateNames state')+++-- Module ---------------------------------------------------------------------+instance Detect (Module ()) where+ detect mm+ = do body' <- liftM (annotate ()) + $ detect (deannotate (const Nothing) $ moduleBody mm)+ importK <- detectMap (moduleImportKinds mm)+ importT <- detectMap (moduleImportTypes mm)++ -- Limit the import types to free vars in body:+ let free = freeX empty body'+ importT' = Map.filterWithKey (\k _ -> Set.member (UName k) free) importT++ return $ ModuleCore+ { moduleName = moduleName mm+ , moduleExportKinds = Map.empty+ , moduleExportTypes = Map.empty+ , moduleImportKinds = importK+ , moduleImportTypes = importT'+ , moduleBody = body' }+++-- Convert the FatNames of an import map+detectMap :: Map FatName (QualName FatName, Type FatName)+ -> State DetectS (Map Name (QualName Name, Type Name))+detectMap m+ = do let ms = Map.toList m+ ms' <- mapM detect' ms+ return $ Map.fromList ms'+ where+ detect' (FatName _ k,(QualName mn (FatName _ n), t))+ = do t' <- detect t+ return (k, (QualName mn n, t'))+++-- DaCon ----------------------------------------------------------------------+instance Detect DaCon where+ detect (DaCon dcn t isAlg)+ = do dcn' <- detect dcn+ t' <- detect t+ return $ DaCon dcn' t' isAlg+++instance Detect DaConName where+ detect dcn+ = case dcn of+ DaConUnit + -> return DaConUnit++ -- Booleans+ DaConNamed (FatName g d@(NameCon v))+ | isPrefixOf "True_" v+ -> do collect d g+ return $ DaConNamed (NameLitBool True)+ DaConNamed (FatName g d@(NameCon v))+ | isPrefixOf "False_" v+ -> do collect d g+ return $ DaConNamed (NameLitBool False)++ -- TODO This should have been a NameCon+ DaConNamed (FatName g d@(NameVar v))+ | isPrefixOf "(,)_" v+ -> do collect d g+ return $ DaConNamed (NameDaConFlow (DaConFlowTuple 2))++ DaConNamed (FatName g d)+ -> do collect d g+ return $ DaConNamed d+++-- Exp ------------------------------------------------------------------------+instance Detect (Exp a) where+ detect xx+ | XAnnot a x <- xx+ = liftM (XAnnot a) $ detect x++ -- Set kind of detected rate variables to Rate.+ | XLam b x <- xx+ = do b' <- detect b+ x' <- detect x+ case b' of+ BName n _+ -> do rateVar <- isRateVar n+ if rateVar + then return $ XLAM (BName n kRate) x'+ else return $ XLam b' x'++ _ -> error "repa-plugin.detect[Exp] no match"++ -- Detect vectorOfSeries+ | XApp{} <- xx+ , Just (XVar u, [xTK, xTA, _xD, xS]) + <- takeXApps xx+ , UName (FatName _ (NameVar v)) <- u+ , isPrefixOf "toVector_" v+ = do args' <- mapM detect [xTK, xTA, xS]+ return $ xApps (XVar (UPrim (NameOpFlow OpFlowVectorOfSeries)+ (typeOpFlow OpFlowVectorOfSeries)))+ args'++ -- Detect folds.+ | XApp{} <- xx+ , Just (XVar uFold, [xTK, xTA, xTB, _xD, xF, xZ, xS]) + <- takeXApps xx+ , UName (FatName _ (NameVar vFold)) <- uFold+ , isPrefixOf "fold_" vFold+ = do args' <- mapM detect [xTK, xTA, xTB, xF, xZ, xS]+ return $ xApps (XVar (UPrim (NameOpFlow OpFlowFold) + (typeOpFlow OpFlowFold)))+ args'++ -- foldIndex+ | XApp{} <- xx+ , Just (XVar uFold, [xTK, xTA, xTB, _xD, xF, xZ, xS]) + <- takeXApps xx+ , UName (FatName _ (NameVar vFold)) <- uFold+ , isPrefixOf "foldIndex_" vFold+ = do args' <- mapM detect [xTK, xTA, xTB, xF, xZ, xS]+ return $ xApps (XVar (UPrim (NameOpFlow OpFlowFoldIndex) + (typeOpFlow OpFlowFoldIndex)))+ args'+++ -- Detect maps+ | XApp{} <- xx+ , Just (XVar uMap, [xTK, xTA, xTB, _xD1, _xD2, xF, xS ])+ <- takeXApps xx+ , UName (FatName _ (NameVar vMap)) <- uMap+ , isPrefixOf "map_" vMap+ = do args' <- mapM detect [xTK, xTA, xTB, xF, xS]+ return $ xApps (XVar (UPrim (NameOpFlow (OpFlowMap 1))+ (typeOpFlow (OpFlowMap 1))))+ args'++ -- TODO mapN+ | XApp{} <- xx+ , Just (XVar uMap, [xTK, xTA, xTB, xTC, _xD1, _xD2, _xD3, xF, xS1, xS2 ])+ <- takeXApps xx+ , UName (FatName _ (NameVar vMap)) <- uMap+ , isPrefixOf "map2_" vMap+ = do args' <- mapM detect [xTK, xTA, xTB, xTC, xF, xS1, xS2]+ return $ xApps (XVar (UPrim (NameOpFlow (OpFlowMap 2))+ (typeOpFlow (OpFlowMap 2))))+ args'++ -- Detect packs+ | XApp{} <- xx+ , Just (XVar uPack, [xTK1, xTK2, xTA, _xD1, xSel, xF])+ <- takeXApps xx+ , UName (FatName _ (NameVar vPack)) <- uPack+ , isPrefixOf "pack_" vPack+ = do args' <- mapM detect [xTK1, xTK2, xTA, xSel, xF]+ return $ xApps (XVar (UPrim (NameOpFlow OpFlowPack)+ (typeOpFlow OpFlowPack)))+ args'++ -- Detect mkSels+ | XApp{} <- xx+ , Just (XVar u, [xTK, xTA, xFlags, xWorker])+ <- takeXApps xx+ , UName (FatName _ (NameVar v)) <- u+ , isPrefixOf "mkSel1_" v+ = do args' <- mapM detect [xTK, xTA, xFlags, xWorker]+ return $ xApps (XVar (UPrim (NameOpFlow (OpFlowMkSel 1))+ (typeOpFlow (OpFlowMkSel 1))))+ args'++ -- Detect n-tuples+ | XApp{} <- xx+ , Just (XVar uTuple, args) <- takeXApps xx+ , UName (FatName _ (NameVar vTuple)) <- uTuple++ , size <- length args `div` 2+ , commas <- replicate (size-1) ','+ , prefix <- "(" ++ commas ++ ")_"++ , size > 1+ , isPrefixOf prefix vTuple+ = do args' <- mapM detect args+ let tuple = DaConFlowTuple size+ ty = typeDaConFlow tuple+ return $ xApps (XCon $ mkDaConAlg (NameDaConFlow tuple) ty)+ args'+++ -- Inject type arguments for arithmetic ops.+ -- In the Core code, arithmetic operations are expressed as monomorphic+ -- dictionary methods, which we convert to polytypic DDC primops.+ | XVar (UName (FatName nG (NameVar str))) <- xx+ , Just (nD', tArg, tPrim) <- matchPrimArith str+ = do collect nD' nG+ return $ xApps (XVar (UPrim nD' tPrim)) [XType tArg]+++ -- Strip boxing constructors from literal values.+ | XApp (XVar (UName (FatName _ (NameCon str1)))) x2 <- xx+ , isPrefixOf "I#_" str1+ = detect x2++ + -- Boilerplate traversal.+ | otherwise+ = case xx of+ XAnnot a x -> liftM (XAnnot a) (detect x)+ XVar u -> liftM XVar (detect u)+ XCon u -> liftM XCon (detect u)+ XLAM b x -> liftM2 XLAM (detect b) (detect x)+ XLam b x -> liftM2 XLam (detect b) (detect x)+ XApp x1 x2 -> liftM2 XApp (detect x1) (detect x2)+ XLet lts x -> liftM2 XLet (detect lts) (detect x)+ XType t -> liftM XType (detect t)++ XCase x alts -> liftM2 XCase (detect x) (mapM detect alts)+ XCast{} -> error "repa-plugin.detect: XCast not handled"+ XWitness{} -> error "repa-plugin.detect: XWitness not handled"+++-- Match arithmetic operators.+matchPrimArith :: String -> Maybe (Name, Type Name, Type Name)+matchPrimArith str+ -- Num+ | isPrefixOf "$fNumInt_$c+_" str + = Just (NamePrimArith PrimArithAdd, tInt, typePrimArith PrimArithAdd)++ | isPrefixOf "$fNumInt_$c-_" str + = Just (NamePrimArith PrimArithSub, tInt, typePrimArith PrimArithSub)++ | isPrefixOf "$fNumInt_$c*_" str+ = Just (NamePrimArith PrimArithMul, tInt, typePrimArith PrimArithMul)++ -- Integral+ | isPrefixOf "$fIntegralInt_$cdiv_" str+ = Just (NamePrimArith PrimArithDiv, tInt, typePrimArith PrimArithDiv)++ | isPrefixOf "$fIntegralInt_$crem_" str+ = Just (NamePrimArith PrimArithRem, tInt, typePrimArith PrimArithRem)++ | isPrefixOf "$fIntegralInt_$cmod_" str+ = Just (NamePrimArith PrimArithMod, tInt, typePrimArith PrimArithMod)++ -- Eq+ | isPrefixOf "eqInt_" str+ = Just (NamePrimArith PrimArithEq, tInt, typePrimArith PrimArithEq)++ | isPrefixOf "gtInt_" str+ = Just (NamePrimArith PrimArithGt, tInt, typePrimArith PrimArithGt)++ | isPrefixOf "ltInt_" str+ = Just (NamePrimArith PrimArithLt, tInt, typePrimArith PrimArithLt)++ | otherwise+ = Nothing+++--- Lets ----------------------------------------------------------------------+instance Detect (Lets a) where+ detect ll+ = case ll of+ LLet b x + -> do b' <- detect b+ x' <- detect x+ return $ LLet b' x'++ LRec bxs + -> do let (bs, xs) = unzip bxs+ bs' <- mapM detect bs+ xs' <- mapM detect xs+ return $ LRec $ zip bs' xs'++ LLetRegions{} -> error "repa-plugin.detect: LLetRegions not handled"+ LWithRegion{} -> error "repa-plugin.detect: LWithRegions not handled"+++--- Alt ----------------------------------------------------------------------+instance Detect (Alt a) where+ detect (AAlt p x)+ = liftM2 AAlt (detect p) (detect x)++instance Detect Pat where+ detect p+ = case p of+ PDefault+ -> return PDefault++ PData dc bs+ -> liftM2 PData (detect dc) (mapM detect bs)+
+ Data/Array/Repa/Plugin/ToDDC/Detect/Base.hs view
@@ -0,0 +1,67 @@++module Data.Array.Repa.Plugin.ToDDC.Detect.Base+ ( Detect (..)+ , DetectS (..)+ , zeroState+ , collect+ , setRateVar+ , isRateVar)+where+import DDC.Core.Flow+import Data.Array.Repa.Plugin.FatName+import Data.Map (Map)+import Data.Set (Set)+import Control.Monad.State.Strict+import qualified Data.Map as Map+import qualified Data.Set as Set+++-- Detect ---------------------------------------------------------------------+-- | Detect series operators in code converted from GHC Core, rewriting the raw+-- AST converted from GHC to be a well formed Disciple Core program. At the +-- same time, remember the mapping from Disciple to GHC core names so we can+-- convert the transformed Disciple program back to GHC core.++-- After this pass the code should type check.+class Detect (c :: * -> *) where+ detect :: c FatName -> State DetectS (c Name)+++-- Detect State ---------------------------------------------------------------+data DetectS + = DetectS+ { -- Map of Disciple Core names to GHC Core Names.+ stateNames :: Map Name GhcName++ -- Names of rate variables, which we discover as they are arguments+ -- of Stream type constructors. + -- In GHC core rate variables have kind '*', + -- but for Disciple Core we change them to have kind 'Rate'.+ , stateRateVars :: Set Name }+++-- | Initial detector state.+zeroState :: DetectS+zeroState+ = DetectS+ { stateNames = Map.empty+ , stateRateVars = Set.empty }+++-- | Remember a mapping between a DDC and GHC name.+collect :: Name -> GhcName -> State DetectS ()+collect !d !g+ = modify $ \s -> s { stateNames = Map.insert d g (stateNames s) }+++-- | Remember that is a rate variable.+setRateVar :: Name -> State DetectS ()+setRateVar !name+ = modify $ \s -> s { stateRateVars = Set.insert name (stateRateVars s) }+++-- | Check whether this is a rate variable.+isRateVar :: Name -> State DetectS Bool+isRateVar name+ = do s <- gets stateRateVars + return $ Set.member name s
+ Data/Array/Repa/Plugin/ToDDC/Detect/Type.hs view
@@ -0,0 +1,219 @@++module Data.Array.Repa.Plugin.ToDDC.Detect.Type where+import DDC.Core.Compounds+import DDC.Core.Exp+import DDC.Core.Flow+import DDC.Core.Flow.Compounds+import Data.Array.Repa.Plugin.FatName+import Data.Array.Repa.Plugin.ToDDC.Detect.Base+import Control.Monad.State.Strict+import qualified DDC.Type.Sum as Sum+import Data.List++import qualified Kind as G+import qualified TyCon as G+import qualified Var as G++-- Bind -----------------------------------------------------------------------+instance Detect Bind where+ detect b+ = case b of+ BName (FatName g d) t1+ -> do collect d g+ t1' <- detect t1+ return $ BName d t1'++ BAnon t -> liftM BAnon (detect t)+ BNone t -> liftM BNone (detect t)+++-- Bound ----------------------------------------------------------------------+instance Detect Bound where+ detect u+ = case u of+ UName n@(FatName g d)++ -- Primitive type constructors.+ | Just g' <- matchPrim "Bool_" n+ -> makePrim g' (NamePrimTyCon PrimTyConBool) kData++ | Just g' <- matchPrim "Int_" n+ -> makePrim g' (NamePrimTyCon PrimTyConInt) kData++ | Just g' <- matchPrim "Int#_" n+ -> makePrim g' (NamePrimTyCon PrimTyConInt) kData++ | Just g' <- matchPrim "Word8_" n+ -> makePrim g' (NamePrimTyCon (PrimTyConWord 8)) kData++ | Just g' <- matchPrim "Word16_" n+ -> makePrim g' (NamePrimTyCon (PrimTyConWord 16)) kData++ | Just g' <- matchPrim "Word32_" n+ -> makePrim g' (NamePrimTyCon (PrimTyConWord 32)) kData++ | Just g' <- matchPrim "Word64_" n+ -> makePrim g' (NamePrimTyCon (PrimTyConWord 64)) kData++ | Just g' <- matchPrim "Float_" n+ -> makePrim g' (NamePrimTyCon (PrimTyConFloat 32)) kData++ | Just g' <- matchPrim "Double_" n+ -> makePrim g' (NamePrimTyCon (PrimTyConFloat 64)) kData+++ -- Vectors, series and selectors.+ | Just g' <- matchPrim "Vector_" n+ -- Find ghc's kind for the var+ -- Only if it's a data type, not a Constraint?+ , not $ returnsConstraintKind g'+ -> makePrim g' (NameTyConFlow TyConFlowVector) + (kData `kFun` kData)++ | Just g' <- matchPrim "Series_" n+ -> makePrim g' (NameTyConFlow TyConFlowSeries) + (kRate `kFun` kData `kFun` kData)++ | Just g' <- matchPrim "Sel1_" n+ -> makePrim g' (NameTyConFlow (TyConFlowSel 1))+ (kRate `kFun` kRate `kFun` kData)++ -- N-tuples: (,)_ etc. Holds one more than the number of commas+ | Just (str, g') <- stringPrim n+ , '(':rest <- str+ , (commas,aftercommas) <- span (==',') rest+ , isPrefixOf ")_" aftercommas+ , size <- length commas + 1+ -> do let k = foldr kFun kData (replicate size kData)+ makePrim g' (NameTyConFlow (TyConFlowTuple size)) k++ | otherwise+ -> do collect d g+ return $ UName d++ UIx ix+ -> return $ UIx ix++ UPrim (FatName g d) t+ -> do collect d g+ t' <- detect t+ return $ UPrim d t'+++matchPrim str n+ | Just (str', g) <- stringPrim n+ , isPrefixOf str str' = Just g++ | otherwise = Nothing+++stringPrim n+ | FatName g (NameVar str') <- n+ = Just (str', g)++ | FatName g (NameCon str') <- n+ = Just (str', g)++ | otherwise+ = Nothing+++makePrim g d t+ = do collect d g+ return $ UPrim d t+++returnsConstraintKind :: GhcName -> Bool+returnsConstraintKind g+ = case g of+ GhcNameVar v -> G.returnsConstraintKind $ G.varType v+ GhcNameTyCon tc -> G.returnsConstraintKind $ G.tyConKind tc+ _ -> False+++-- TyCon ----------------------------------------------------------------------+instance Detect TyCon where+ detect tc+ = case tc of+ TyConSort tc' -> return $ TyConSort tc'+ TyConKind tc' -> return $ TyConKind tc'+ TyConWitness tc' -> return $ TyConWitness tc'+ TyConSpec tc' -> return $ TyConSpec tc'++ TyConBound u k+ -> do u' <- detect u+ k' <- detect k+ case u' of+ UPrim _ k2 -> return $ TyConBound u' k2+ _ -> return $ TyConBound u' k'++++-- Type ------------------------------------------------------------------------+instance Detect Type where+ detect tt++ -- Detect rate variables being applied to Series type constructors.+ | TApp t1 t2 <- tt+ , [ TCon (TyConBound (UName (FatName _ (NameCon str))) _)+ , TVar (UName (FatName _ n))+ , _] + <- takeTApps tt+ , isPrefixOf "Series_" str+ = do setRateVar n+ t1' <- detect t1+ t2' <- detect t2+ return $ TApp t1' t2'++ -- Detect rate variables being applied to Sel1 type constructors.+ | TApp t1 t2 <- tt+ , [ TCon (TyConBound (UName (FatName _ (NameCon str))) _)+ , TVar (UName (FatName _ n1))+ , TVar (UName (FatName _ n2))] + <- takeTApps tt+ , isPrefixOf "Sel1_" str+ = do setRateVar n1+ setRateVar n2+ t1' <- detect t1+ t2' <- detect t2+ return $ TApp t1' t2'+++ -- Set kind of detected rate variables to Rate.+ | TForall b t <- tt+ = do t' <- detect t+ b' <- detect b+ case b' of+ BName n _+ -> do rateVar <- isRateVar n+ if rateVar+ then return $ TForall (BName n kRate) t'+ else return $ TForall b' t'++ _ -> error "repa-plugin.detect no match"++ -- Convert all kindy things to kData+ | TCon (TyConBound (UName n) _) <- tt+ , Just _ <- matchPrim "*_" n+ = do return $ TCon (TyConKind KiConData)++ | TCon (TyConBound (UName n) _) <- tt+ , Just _ <- matchPrim "#_" n+ = do return $ TCon (TyConKind KiConData)++ | TCon (TyConBound (UName n) _) <- tt+ , Just _ <- matchPrim "Constraint_" n+ = do return $ TCon (TyConKind KiConData)+ + -- Boilerplate traversal.+ | otherwise+ = case tt of+ TVar u -> liftM TVar (detect u)+ TCon c -> liftM TCon (detect c)+ TForall b t -> liftM2 TForall (detect b) (detect t)+ TApp t1 t2 -> liftM2 TApp (detect t1) (detect t2)+ TSum ts + -> do k <- detect $ Sum.kindOfSum ts+ tss' <- liftM (Sum.fromList k) $ mapM detect $ Sum.toList ts+ return $ TSum tss'+
+ Data/Array/Repa/Plugin/ToGHC.hs view
@@ -0,0 +1,482 @@++module Data.Array.Repa.Plugin.ToGHC+ (spliceModGuts)+where+import Data.Array.Repa.Plugin.ToGHC.Wrap+import Data.Array.Repa.Plugin.ToGHC.Type+import Data.Array.Repa.Plugin.ToGHC.Prim+import Data.Array.Repa.Plugin.ToGHC.Var+import Data.Array.Repa.Plugin.Primitives+import Data.Array.Repa.Plugin.FatName++import qualified BasicTypes as G+import qualified HscTypes as G+import qualified CoreSyn as G+import qualified Type as G+import qualified TypeRep as G+import qualified TysPrim as G+import qualified TysWiredIn as G+import qualified Var as G+import qualified DataCon as G+import qualified Literal as G+import qualified UniqSupply as G++import DDC.Base.Pretty+import qualified DDC.Core.Exp as D+import qualified DDC.Core.Module as D+import qualified DDC.Core.Compounds as D+import qualified DDC.Core.Flow as D+import qualified DDC.Core.Flow.Prim as D+import qualified DDC.Base.Pretty as D++import Data.List+import Control.Monad+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (catMaybes)+++-------------------------------------------------------------------------------+-- | Splice bindings from a DDC module into a GHC core program.+--+-- If the GHC module contains a top-level binding that map onto a binding+-- in the DDC module then add the converted DDC binding to the GHC module+-- and patch the original GHC binding to call it.+--+spliceModGuts+ :: Primitives -- ^ Table of Repa primitives+ -> Map D.Name GhcName -- ^ Maps DDC names to GHC names.+ -> D.Module () D.Name -- ^ DDC module.+ -> G.ModGuts -- ^ GHC module guts.+ -> G.UniqSM G.ModGuts++spliceModGuts primitives names mm guts+ = do + -- Invert the map so it maps GHC names to DDC names.+ let names' = Map.fromList + $ map (\(x, y) -> (y, x)) + $ Map.toList names++ binds' <- liftM concat + $ mapM (spliceBind primitives guts names names' mm) + $ G.mg_binds guts++ return $ guts { G.mg_binds = binds' }+++-- Splice ---------------------------------------------------------------------+-- | If a GHC core binding has a matching one in the provided DDC module+-- then convert the DDC binding from GHC core and use that instead.+spliceBind + :: Primitives+ -> G.ModGuts+ -> Map D.Name GhcName+ -> Map GhcName D.Name+ -> D.Module () D.Name+ -> G.CoreBind+ -> G.UniqSM [G.CoreBind]++-- If there is a matching binding in the Disciple module then use that.+spliceBind primitives guts names names' mm (G.NonRec gbOrig _)+ | Just nOrig <- Map.lookup (GhcNameVar gbOrig) names'+ , Just (dbLowered, dxLowered) <- lookupModuleBindOfName mm nOrig+ = do + -- starting environments.+ -- let imported = importedNamesOfGuts guts++ let kenv = Env+ { envGuts = guts+ , envPrimitives = primitives+ , envNames = names+ , envVars = [] }++ let tenv = Env+ { envGuts = guts+ , envPrimitives = primitives+ , envNames = names+ , envVars = [] }++ -- make a new binding for the lowered version.+ let dtLowered = D.typeOfBind dbLowered+ gtLowered <- convertType kenv dtLowered+ gvLowered <- newDummyVar "lowered" gtLowered++ -- Convert the lowered version from DDC to GHC core.+ (gxLowered, _) <- convertExp kenv tenv dxLowered++ -- Call the lowered version from the original, adding a wrapper+ -- to (unsafely) pass the world token and marshal boxed to+ -- unboxed values.+ xCall <- wrapLowered + (G.varType gbOrig) gtLowered+ [] + gvLowered++ return [ G.NonRec gvLowered gxLowered+ , G.NonRec gbOrig xCall ]+ -- TODO: ensure the NOINLINE pragma is attached so we know+ -- the faked realWorld token will never be substituted.++-- Otherwise leave the original GHC binding as it is.+spliceBind _ _ _ _ _ b+ = return [b]+++-------------------------------------------------------------------------------+-- | Lookup a top-level binding from a DDC module.+lookupModuleBindOfName+ :: D.Module () D.Name + -> D.Name + -> Maybe ( D.Bind D.Name+ , D.Exp () D.Name)++lookupModuleBindOfName mm n+ | D.XLet _ (D.LRec bxs) _ <- D.moduleBody mm+ = find (\(b, _) -> D.takeNameOfBind b == Just n) bxs++ | otherwise+ = Nothing+++-- Top -----------------------------------------------------------------------+convertExp+ :: Env -> Env+ -> D.Exp () D.Name+ -> G.UniqSM (G.CoreExpr, G.Type)++convertExp kenv tenv xx+ = case xx of+ -- Variables.+ -- Names of plain variables should be in the name map, and refer other+ -- top-level bindings, or dummy variables that we've introduced locally+ -- in this function.+ -- If they're not in envVars, they may be imported functions in envNames.+ D.XVar _ (D.UName dn)+ -> case lookup dn (envVars tenv) of+ Nothing + | Just (GhcNameVar gv) <- Map.lookup dn (envNames tenv)+ -> return (G.Var gv, G.varType gv)++ Nothing+ -> error $ unlines + [ "repa-plugin.ToGHC.convertExp: variable " + ++ show dn ++ " not in scope"+ , "env = " ++ show (map fst $ envVars tenv) ]+ Just gv+ -> return ( G.Var gv+ , G.varType gv)++ -- Non-polytypic primops.+ D.XVar _ (D.UPrim n _)+ | not $ isPolytypicPrimName n+ -> convertPrim kenv tenv n+++ -- RateOfRateNat is Id+ D.XApp{}+ | Just (n, [_xTK, xRate]) <- D.takeXPrimApps xx+ , D.NameOpFlow D.OpFlowNatOfRateNat <- n+ -> convertExp kenv tenv xRate+++ -- The unboxed tuple constructor.+ -- When we produce unboxed tuple we always want to preserve+ -- the unboxed versions of element types.+ D.XApp _ x1 x2+ | (D.XCon _ (D.DaCon dn _ _), args) <- D.takeXApps1 x1 x2+ , D.DaConNamed (D.NameDaConFlow (D.DaConFlowTuple n)) <- dn++ -- The first n arguments are type parameters, the rest are values+ , (tyxs, vals) <- splitAt n args+ , tys <- catMaybes (map D.takeXType tyxs)++ -- Types must be fully applied, but we can get away with+ -- only partial value application+ , length tys == n+ -> do tys' <- mapM (convertType_unboxed kenv) tys+ vals' <- mapM (convertExp kenv tenv) vals++ let dacon = G.tupleCon G.UnboxedTuple n+ -- Find type of tuple constructor, instantiate the foralls+ let gt = G.varType (G.dataConWorkId dacon)+ let gt' = G.applyTys gt tys'+ -- Get the result of the function type after applying the arguments in vals+ let (_,tRes) = G.splitFunTysN (length vals) gt'++ return ( G.mkConApp dacon (map G.Type tys' ++ map fst vals')+ , tRes )+++ -- Data constructors. + D.XCon _ (D.DaCon dn _ _)+ -> case dn of -- TODO: shift into Prim module.+ -- Unit constructor.+ D.DaConUnit+ -> return ( G.Var (G.dataConWorkId G.unitDataCon)+ , G.unitTy )++ -- Int# literal+ D.DaConNamed (D.NameLitInt i)+ -> return ( G.Lit (G.MachInt i)+ , G.intPrimTy)++ -- Nat# literal+ -- Disciple unsigned Nat#s just get squashed onto GHC Int#s.+ D.DaConNamed (D.NameLitNat i)+ -> return ( G.Lit (G.MachInt i)+ , G.intPrimTy)++ -- Don't know how to convert this.+ _ -> error $ "repa-plugin.ToGHC.convertExp: "+ ++ "Cannot convert DDC data constructor " + ++ show xx ++ " to GHC Core."+++ -- Type abstractions.+ D.XLAM _ b@(D.BName{}) xBody+ -> do + (kenv', gv) <- bindVarT kenv b+ (xBody', tBody') <- convertExp kenv' tenv xBody++ return ( G.Lam gv xBody'+ , G.mkForAllTy gv tBody')++ -- Non-binding function abstractions.+ D.XLam _ b@(D.BNone{}) xBody+ -> do gt <- convertType kenv (D.typeOfBind b)+ gv <- newDummyVar "z" gt+ (xBody', tBody') <- convertExp kenv tenv xBody++ return ( G.Lam gv xBody'+ , G.mkFunTy gt tBody')++ -- Function abstractions.+ D.XLam _ b@(D.BName{}) xBody+ -> do + (tenv', gv) <- bindVarX kenv tenv b+ (xBody', tBody') <- convertExp kenv tenv' xBody++ return ( G.Lam gv xBody'+ , G.mkFunTy (G.varType gv) tBody')+++ -- Application of a polytypic primitive.+ -- In GHC core, functions cannot be polymorphic in unlifted primitive+ -- types. We convert most of the DDC polymorphic prims in a uniform way.+ D.XApp _ (D.XApp _ (D.XVar _ (D.UPrim n _)) (D.XType t1)) (D.XType t2)+ | isPolytypicPrimName n+ -> convertPolytypicPrim kenv tenv n [t1, t2]++ D.XApp _ (D.XVar _ (D.UPrim n _)) (D.XType t)+ | isPolytypicPrimName n+ -> convertPolytypicPrim kenv tenv n [t]+++ -- Value/Type applications.+ D.XApp _ x1 (D.XType t2)+ -> do (x1', t1') <- convertExp kenv tenv x1+ t2' <- convertType_boxed kenv t2++ let tResult+ = case t1' of+ G.ForAllTy{} + -> G.applyTy t1' t2'++ _ -> error + $ renderIndent $ vcat+ [ text $ "repa-plugin.ToGHC.convertExp: in value/type application"+ ++ " type error during conversion."+ , ppr x1 + , ppr x1' <+> text "::" <+> (ppr t1')+ , ppr t2 ]++ return ( G.App x1' (G.Type t2')+ , tResult)++ -- Value/Value applications.+ D.XApp _ x1 x2+ -> do (x1', t1') <- convertExp kenv tenv x1+ (x2', t2') <- convertExp kenv tenv x2++ let (tArg, tResult)+ = case t1' of+ G.FunTy t11' t12' + -> (t11', t12')++ _ -> error + $ renderIndent $ vcat+ [ text $ "repa-plugin.ToGHC.convertExp: in value/value application"+ ++ " type error during conversion."+ , ppr x1+ , ppr x2 ]++ x2'' <- unwrapResult tArg t2' x2'++ return ( G.App x1' x2''+ , tResult)++ -- Recursive let-binding+ D.XLet _ (D.LRec [(b, x)]) x2+ -> do + (tenv', vBind') <- bindVarX kenv tenv b+ (x', _) <- convertExp kenv tenv' x+ (x2', t2') <- convertExp kenv tenv' x2++ return ( G.Let (G.Rec [(vBind', x')]) x2'+ , t2')++ -- Non-recursive let bindings+ D.XLet _ (D.LLet b x1) x2+ -> do (xScrut', tScrut')<- convertExp kenv tenv x1+ (tenv', vBind') <- bindVarX kenv tenv b++ -- When using bindVarX, the actual type (tScrut) may be different+ -- from the desired type (type of vBind).+ -- Use unwrapResult to box or unbox xScrut as necessary,+ -- based on the types.+ xScrut'' <- unwrapResult (G.varType vBind') tScrut' xScrut'++ (x2', t2') <- convertExp kenv tenv' x2++ return ( G.Case xScrut'' vBind' t2'+ [ ( G.DEFAULT, [], x2') ]+ , t2')+++ -- Case expresions, with a single binder.+ -- assume these are 1-tuples -- TODO: check really 1-tuples.+ -- TODO: make generic+ D.XCase _ xScrut+ [ D.AAlt (D.PData _ [ bWorld ]) x1]+ -> do+ (xScrut', _) <- convertExp kenv tenv xScrut++ (tenv', vWorld') <- bindVarX kenv tenv bWorld+ (x1', t1') <- convertExp kenv tenv' x1++ return ( G.Case xScrut' vWorld' t1'+ [ (G.DEFAULT, [], x1') ]+ , t1')+++ -- Case expressions over n-tuples -- TODO: make generic+ D.XCase _ xScrut + [ D.AAlt (D.PData dacon binders) x1]+ | D.DaCon dn _ _ <- dacon+ , D.DaConNamed (D.NameDaConFlow (D.DaConFlowTuple n)) <- dn+ , length binders == n+ -> do + (xScrut', tScrut') <- convertExp kenv tenv xScrut+ vScrut' <- newDummyVar "scrut" tScrut'++ let goBind (tenv', vs) b+ = do (tenv'', v) <- bindVarX kenv tenv' b+ return (tenv'', v:vs)++ (tenv',vs) <- foldM goBind (tenv,[]) binders+ (x1', t1') <- convertExp kenv tenv' x1++ return ( G.Case xScrut' vScrut' t1'+ [ (G.DataAlt (G.tupleCon G.UnboxedTuple n)+ , reverse vs, x1') ]+ , t1')++ -- Case expressions over bools+ -- or at least things that look like bools -- TODO: make generic+ D.XCase _ xScrut + [ D.AAlt (D.PData dc1 []) x1,+ D.AAlt (D.PData dc2 []) x2 ]+ | D.DaCon dn1 _ _ <- dc1+ , D.DaConNamed (D.NameLitBool False) == dn1+ , D.DaCon dn2 _ _ <- dc2+ , D.DaConNamed (D.NameLitBool True) == dn2+ -> do + (xScrut', tScrut') <- convertExp kenv tenv xScrut+ vScrut' <- newDummyVar "scrut" tScrut'++ (x1', t1') <- convertExp kenv tenv x1+ (x2', _t2') <- convertExp kenv tenv x2+ -- Assert t1' == t2' ?++ return ( G.Case xScrut' vScrut' t1'+ [ (G.DataAlt G.falseDataCon, [], x1')+ , (G.DataAlt G.trueDataCon, [], x2') ]+ , t1')++ -- Other case expressions.+ D.XCase _ xScrut alts+ -> do + (xScrut', tScrut') <- convertExp kenv tenv xScrut+ vScrut' <- newDummyVar "scrut" tScrut'++ (alts', ts') <- liftM unzip $ mapM (convertAlt kenv tenv) alts+ let t' : _ = ts'++ return ( G.Case xScrut' vScrut' t' (shuffleAlts alts')+ , t')+++ _ -> errorNoConversion xx+++-------------------------------------------------------------------------------+convertAlt + :: Env -> Env+ -> D.Alt () D.Name+ -> G.UniqSM (G.CoreAlt, G.Type)++convertAlt kenv tenv aalt++ -- Default alternative.+ | D.AAlt D.PDefault x <- aalt+ = do (x', t') <- convertExp kenv tenv x+ return ( ( G.DEFAULT, [], x')+ , t')++ -- Alternative matching an integer.+ | D.AAlt (D.PData dc []) x <- aalt+ , D.DaCon dn _ _ <- dc+ , D.DaConNamed (D.NameLitInt i) <- dn+ = do (x', t') <- convertExp kenv tenv x+ return ( ( G.LitAlt (G.MachInt i), [], x')+ , t')++ -- Alternative matching a boolean+ | D.AAlt (D.PData dc []) x <- aalt+ , D.DaCon dn _ _ <- dc+ , D.DaConNamed (D.NameLitBool flag) <- dn+ = do (x', t') <- convertExp kenv tenv x+ let altcon = case flag of+ True -> G.DataAlt G.trueDataCon+ False -> G.DataAlt G.falseDataCon++ return ( ( altcon, [], x')+ , t')+++ | otherwise+ = errorNoConversion aalt+++-- | Ensure any default alternative comes first.+-- The GHC code generator panics if there is a default alt which is not first.+shuffleAlts :: [G.CoreAlt] -> [G.CoreAlt]+shuffleAlts alts+ = go [] alts+ where + go _ []+ = []++ go acc (a : more)+ = case a of+ (G.DEFAULT, [], _) -> (a : acc) ++ more+ _ -> go (acc ++ [a]) more+++-- Errors ---------------------------------------------------------------------+errorNoConversion xx+ = error $ D.renderIndent $ D.vcat+ $ [ D.text "repa-plugin.ToGHC: cannot convert this to GHC Core"+ , D.empty+ , D.indent 8 $ D.ppr xx ]+
+ Data/Array/Repa/Plugin/ToGHC/Prim.hs view
@@ -0,0 +1,238 @@++module Data.Array.Repa.Plugin.ToGHC.Prim+ ( convertPrim+ , convertPolytypicPrim+ , isPolytypicPrimName)+where+import Data.Array.Repa.Plugin.Primitives+import Data.Array.Repa.Plugin.ToGHC.Type++import qualified HscTypes as G+import qualified CoreSyn as G+import qualified Type as G+import qualified UniqSupply as G++import qualified DDC.Core.Exp as D+import qualified DDC.Core.Flow as D+import qualified DDC.Core.Flow.Prim as D+import qualified DDC.Core.Flow.Compounds as D+++-- | Convert a primop that has the same definition independent +-- of its type arguments.+convertPrim + :: Env -> Env+ -> D.Name+ -> G.UniqSM (G.CoreExpr, G.Type)++convertPrim _kenv tenv n + = let prims = envPrimitives tenv+ in case n of+ D.NameOpFlow D.OpFlowRateOfSeries+ -> return $ prim_rateOfSeries prims++ D.NameOpLoop D.OpLoopGuard+ -> return $ prim_guard prims++ -- ERROR: This isn't a primtive name,+ -- or we don't have an implementation for it.+ _ -> errorMissingPrim (envGuts tenv) n Nothing+++-------------------------------------------------------------------------------+-- | Convert a primop that has a different definition depending on the type+-- argument. If primops handled by this function must be detected by+-- `isPolyTypicPrimName` below.+convertPolytypicPrim + :: Env -> Env+ -> D.Name -> [D.Type D.Name]+ -> G.UniqSM (G.CoreExpr, G.Type)++convertPolytypicPrim kenv _tenv n tsArg+ = let prims = envPrimitives kenv+ in case n of++ -- Arith+ D.NamePrimArith D.PrimArithAdd+ | tsArg == [D.tNat] -> return $ prim_addInt prims+ | tsArg == [D.tInt] -> return $ prim_addInt prims++ D.NamePrimArith D.PrimArithSub+ | tsArg == [D.tNat] -> return $ prim_subInt prims+ | tsArg == [D.tInt] -> return $ prim_subInt prims++ D.NamePrimArith D.PrimArithMul+ | tsArg == [D.tNat] -> return $ prim_mulInt prims+ | tsArg == [D.tInt] -> return $ prim_mulInt prims++ D.NamePrimArith D.PrimArithDiv+ | tsArg == [D.tNat] -> return $ prim_divInt prims+ | tsArg == [D.tInt] -> return $ prim_divInt prims++ D.NamePrimArith D.PrimArithMod+ | tsArg == [D.tNat] -> return $ prim_modInt prims+ | tsArg == [D.tInt] -> return $ prim_modInt prims++ D.NamePrimArith D.PrimArithRem+ | tsArg == [D.tNat] -> return $ prim_remInt prims+ | tsArg == [D.tInt] -> return $ prim_remInt prims++ -- Eq+ D.NamePrimArith D.PrimArithEq+ | tsArg == [D.tNat] -> return $ prim_eqInt prims+ | tsArg == [D.tInt] -> return $ prim_eqInt prims++ D.NamePrimArith D.PrimArithNeq+ | tsArg == [D.tNat] -> return $ prim_neqInt prims+ | tsArg == [D.tInt] -> return $ prim_neqInt prims++ D.NamePrimArith D.PrimArithGt+ | tsArg == [D.tNat] -> return $ prim_gtInt prims+ | tsArg == [D.tInt] -> return $ prim_gtInt prims++ D.NamePrimArith D.PrimArithGe+ | tsArg == [D.tNat] -> return $ prim_geInt prims+ | tsArg == [D.tInt] -> return $ prim_geInt prims++ D.NamePrimArith D.PrimArithLt+ | tsArg == [D.tNat] -> return $ prim_ltInt prims+ | tsArg == [D.tInt] -> return $ prim_ltInt prims++ D.NamePrimArith D.PrimArithLe+ | tsArg == [D.tNat] -> return $ prim_leInt prims+ | tsArg == [D.tInt] -> return $ prim_leInt prims+++ -- Ref+ D.NameOpStore D.OpStoreNew+ | tsArg == [D.tNat] -> return $ prim_newRefInt prims+ | tsArg == [D.tInt] -> return $ prim_newRefInt prims+ | tsArg == [D.tTuple2 D.tInt D.tInt] -> return $ prim_newRefInt_T2 prims++ D.NameOpStore D.OpStoreRead+ | tsArg == [D.tNat] -> return $ prim_readRefInt prims+ | tsArg == [D.tInt] -> return $ prim_readRefInt prims+ | tsArg == [D.tTuple2 D.tInt D.tInt] -> return $ prim_readRefInt_T2 prims++ D.NameOpStore D.OpStoreWrite+ | tsArg == [D.tNat] -> return $ prim_writeRefInt prims+ | tsArg == [D.tInt] -> return $ prim_writeRefInt prims+ | tsArg == [D.tTuple2 D.tInt D.tInt] -> return $ prim_writeRefInt_T2 prims++ -- Vector+ D.NameOpStore D.OpStoreNewVector+ | tsArg == [D.tNat] -> return $ prim_newVectorInt prims+ | tsArg == [D.tInt] -> return $ prim_newVectorInt prims++ D.NameOpStore D.OpStoreNewVectorN+ | [tA, _tK] <- tsArg, tA == D.tNat -> return $ prim_newVectorInt prims+ | [tA, _tK] <- tsArg, tA == D.tInt -> return $ prim_newVectorInt prims++ D.NameOpStore D.OpStoreReadVector+ | tsArg == [D.tNat] -> return $ prim_readVectorInt prims+ | tsArg == [D.tInt] -> return $ prim_readVectorInt prims++ D.NameOpStore D.OpStoreWriteVector+ | tsArg == [D.tNat] -> return $ prim_writeVectorInt prims+ | tsArg == [D.tInt] -> return $ prim_writeVectorInt prims++ D.NameOpStore D.OpStoreSliceVector+ | tsArg == [D.tNat] -> return $ prim_sliceVectorInt prims+ | tsArg == [D.tInt] -> return $ prim_sliceVectorInt prims++ -- Next+ D.NameOpStore D.OpStoreNext+ | [tA, tK] <- tsArg, tA == D.tInt || tA == D.tNat+ -> do tK' <- convertType kenv tK+ let (x, t) = prim_nextInt prims+ return ( G.App x (G.Type tK')+ , G.applyTy t tK' )++ D.NameOpStore D.OpStoreNext+ | [tA, tK] <- tsArg, tA == D.tTuple2 D.tInt D.tInt+ -> do tK' <- convertType kenv tK+ let (x, t) = prim_nextInt_T2 prims+ return ( G.App x (G.Type tK')+ , G.applyTy t tK' )++ -- Loop+ D.NameOpLoop D.OpLoopLoopN+ -> return $ prim_loop prims+++ -- ERROR: This isn't a primitive name,+ -- or we don't have an implementation for it,+ -- or the function `isPolytypicPrimName` tells lies.+ _ -> errorMissingPrim (envGuts kenv) n Nothing+++-- | Check whether the function with this name must be handled polytypically. +-- This needs to match all the names handled by `convertPolytypicPrim` above.+isPolytypicPrimName :: D.Name -> Bool+isPolytypicPrimName n+ = elem n + [ D.NamePrimArith D.PrimArithAdd+ , D.NamePrimArith D.PrimArithSub+ , D.NamePrimArith D.PrimArithMul+ , D.NamePrimArith D.PrimArithDiv+ , D.NamePrimArith D.PrimArithMod+ , D.NamePrimArith D.PrimArithRem++ , D.NamePrimArith D.PrimArithEq+ , D.NamePrimArith D.PrimArithNeq+ , D.NamePrimArith D.PrimArithGt+ , D.NamePrimArith D.PrimArithGe+ , D.NamePrimArith D.PrimArithLt+ , D.NamePrimArith D.PrimArithLe++ , D.NameOpStore D.OpStoreNew+ , D.NameOpStore D.OpStoreRead+ , D.NameOpStore D.OpStoreWrite+ , D.NameOpStore D.OpStoreNewVector+ , D.NameOpStore D.OpStoreNewVectorN+ , D.NameOpStore D.OpStoreReadVector+ , D.NameOpStore D.OpStoreWriteVector + , D.NameOpStore D.OpStoreSliceVector + , D.NameOpStore D.OpStoreNext++ , D.NameOpLoop D.OpLoopLoopN ]+ ++-- | Complain that we couldn't find a primitive that we needed.+errorMissingPrim :: G.ModGuts -> D.Name -> Maybe String -> a+errorMissingPrim _guts _n (Just str)+ = error $ unlines+ $ map (" " ++)+ [ ""+ , "repa-plugin:"+ , " Cannot find definition for primitive '" ++ str ++ "'"+ , ""+ , " When using the repa-plugin you must import a module that provides"+ , " implementations for the primitives used by the lowering transform."+ , ""+ , " This problem is likely caused by importing just the repa-series"+ , " module that contains the stream operators, but not the module that"+ , " contains the target primitives as well."+ , ""+ , " If you don't want to define your own primitives then try adding"+ , " 'import Data.Array.Repa.Series' to your client module."+ , ""+ , " This is a problem with the Repa plugin, and not GHC proper."+ , " You can ignore the following request to report this as a GHC bug." + , "" ]+++errorMissingPrim _guts n Nothing+ = error $ unlines+ $ map (" " ++)+ [ ""+ , "repa-plugin:"+ , " No Haskell symbol name for Disciple Core Flow primitive:"+ , " '" ++ show n ++ "'"+ , ""+ , " Please report this problem on the Repa bug tracker,"+ , " or complain about it on the Repa mailing list."+ , ""+ , " This is a problem with the Repa plugin, and not GHC proper."+ , " You can ignore the following request to report this as a GHC bug." ]+
+ Data/Array/Repa/Plugin/ToGHC/Type.hs view
@@ -0,0 +1,287 @@++module Data.Array.Repa.Plugin.ToGHC.Type+ ( convertType+ , convertType_boxed+ , convertType_unboxed++ , convertBoxed+ , convertUnboxed+ , Env(..)+ , bindVarT+ , bindVarX)+where+import Data.Array.Repa.Plugin.ToGHC.Var+import Data.Array.Repa.Plugin.Primitives+import Data.Array.Repa.Plugin.FatName+import Data.Map (Map)++import qualified BasicTypes as G+import qualified HscTypes as G+import qualified Type as G+import qualified TypeRep as G+import qualified TysPrim as G+import qualified TysWiredIn as G+import qualified TyCon as G+import qualified UniqSupply as G++import qualified DDC.Core.Exp as D+import qualified DDC.Core.Compounds as D+import qualified DDC.Core.Flow as D+import qualified DDC.Core.Flow.Compounds as D+import qualified DDC.Core.Flow.Prim as D+import qualified DDC.Base.Pretty as D++import qualified Data.Map as Map+++-- Boxed/Unboxed versions -----------------------------------------------------+convertType_boxed+ :: Env+ -> D.Type D.Name+ -> G.UniqSM G.Type++convertType_boxed env tt+ = case convertBoxed tt of+ Just t' -> return t'+ _ -> convertType env tt+++convertType_unboxed+ :: Env+ -> D.Type D.Name+ -> G.UniqSM G.Type++convertType_unboxed env tt+ = case convertUnboxed tt of+ Just t' -> return t'+ _ -> convertType env tt+++-- Type -----------------------------------------------------------------------+convertType + :: Env+ -> D.Type D.Name + -> G.UniqSM G.Type++convertType kenv tt+ = case tt of+ -- DDC[World#] => GHC[State# RealWorld#]+ -- The GHC state token takes a phantom type to indicate+ -- what state thread it corresponds to.+ D.TCon (D.TyConBound (D.UPrim (D.NameTyConFlow D.TyConFlowWorld) _) _)+ -> return $ G.mkTyConApp G.statePrimTyCon [G.realWorldTy]++ -- DDC[Vector# a] => GHC[Vector# {Lifted a}]+ -- In the code we get from the lowering transform, for element+ -- types like Int# the "hash" refers to the fact that it is+ -- primitive, and not nessesarally unboxed. The type arguments + -- for 'Series' in GHC land need to be the boxed/lifted versions.+ D.TApp{}+ | Just (D.NameTyConFlow D.TyConFlowVector, [tElem])+ <- D.takePrimTyConApps tt+ , Just tElem' <- convertBoxed tElem+ -> do return $ G.applyTy (prim_Vector (envPrimitives kenv)) + tElem'++ -- DDC[Ref# a] => GHC[Ref {Lifted a}]+ D.TApp{}+ | Just (D.NameTyConFlow D.TyConFlowRef, [tElem])+ <- D.takePrimTyConApps tt+ , Just tElem' <- convertBoxed tElem+ -> do return $ G.applyTy (prim_Ref (envPrimitives kenv))+ tElem'++ -- DDC[Series# k a] => GHC[Series k {Lifted a}]+ D.TApp{}+ | Just (D.NameTyConFlow D.TyConFlowSeries, [tK, tElem])+ <- D.takePrimTyConApps tt+ , Just tElem' <- convertBoxed tElem+ -> do tK' <- convertType kenv tK+ return $ G.applyTys (prim_Series (envPrimitives kenv)) + [tK', tElem']++ -- DDC[Data] => GHC[*]+ D.TCon (D.TyConKind D.KiConData)+ -> return $ G.liftedTypeKind++ -- DDC[Rate] => GHC[*]+ D.TCon (D.TyConBound (D.UPrim (D.NameKiConFlow D.KiConFlowRate) _) _)+ -> return $ G.liftedTypeKind+++ -- Generic Conversion -------------------+ D.TForall b t+ -> do (kenv', gv) <- bindVarT kenv b+ t' <- convertType kenv' t+ return $ G.mkForAllTy gv t'++ -- Function types.+ D.TApp{}+ | Just (t1, t2) <- D.takeTFun tt+ -> do t1' <- convertType kenv t1+ t2' <- convertType kenv t2+ return $ G.mkFunTy t1' t2'++ -- Applied type constructors.+ D.TApp{}+ | Just (tc, tsArgs) <- D.takeTyConApps tt+ -> do tsArgs' <- mapM (convertType kenv) tsArgs+ tsArgs_b' <- mapM (convertType_boxed kenv) tsArgs+ return $ convertTyConApp + (envPrimitives kenv) (envNames kenv) + tc tsArgs' tsArgs_b'++ D.TCon tc+ -> return $ convertTyConApp + (envPrimitives kenv) (envNames kenv) + tc [] []++ D.TVar (D.UName n)+ -> case lookup n (envVars kenv) of+ Nothing+ -> error $ unlines + [ "repa-plugin.ToGHC.convertType: variable " + ++ show n ++ " not in scope"+ , "env = " ++ show (map fst $ envVars kenv) ]++ Just gv + -> return $ G.TyVarTy gv+++ _ -> error $ "repa-plugin.convertType: no match for " ++ show tt+++-- TyConApp -------------------------------------------------------------------+-- | Covnert a type constructor application.+--+-- Note that our baked-in types Series and Vector are handled by+-- convertType instead.+--+-- We require in the unboxed and boxed argument types:+-- user-defined types require boxed.+convertTyConApp + :: Primitives+ -> Map D.Name GhcName+ -> D.TyCon D.Name+ -> [G.Type] -- ^ Normal (unboxed?) argument types+ -> [G.Type] -- ^ Boxed argument types+ -> G.Type++convertTyConApp _prims names tc tsArgs' tsArgs_b'+ = case tc of+ -- Functions+ D.TyConSpec D.TcConFun+ | [t1, t2] <- tsArgs'+ -> G.FunTy t1 t2++ -- Unit+ D.TyConSpec D.TcConUnit+ | [] <- tsArgs'+ -> G.unitTy++ -- Tuples+ D.TyConBound (D.UPrim (D.NameTyConFlow (D.TyConFlowTuple n)) _) _+ | length tsArgs' == n+ -> G.mkTyConApp (G.tupleTyCon G.UnboxedTuple n) tsArgs'++ -- Machine types+ D.TyConBound (D.UPrim n _) _+ | [] <- tsArgs'+ , Just tc' <- convertTyConPrimName n+ -> G.mkTyConApp tc' tsArgs'++ -- User-defined types: use boxed arguments+ D.TyConBound (D.UName n) _+ | Just (GhcNameTyCon tc') <- Map.lookup n names+ -> G.mkTyConApp tc' tsArgs_b'++ -- Couldn't convert this type constructor application.+ _ -> error $ "repa-plugin.convertTyConApp: no match for " + ++ show tc +++-- TyCon ----------------------------------------------------------------------+-- | Convert a Flow type constructor name to a GHC type constructor.+convertTyConPrimName :: D.Name -> Maybe G.TyCon+convertTyConPrimName n+ = case n of+ D.NamePrimTyCon D.PrimTyConBool -> Just G.boolTyCon+ D.NamePrimTyCon D.PrimTyConNat -> Just G.intPrimTyCon+ D.NamePrimTyCon D.PrimTyConInt -> Just G.intPrimTyCon++ _ -> Nothing+++-------------------------------------------------------------------------------+-- | Get the GHC boxed type corresponding to this Flow series element type.+convertBoxed :: D.Type D.Name -> Maybe G.Type+convertBoxed t+ | t == D.tNat = Just G.intTy+ | t == D.tInt = Just G.intTy++ | Just (tc,args) <- D.takeTyConApps t+ , D.TyConBound (D.UPrim (D.NameTyConFlow (D.TyConFlowTuple n)) _) _+ <- tc+ , Just args' <- mapM convertBoxed args+ = Just $ G.mkTyConApp (G.tupleTyCon G.BoxedTuple n) args'++ | otherwise = Nothing+++-- | Get the GHC unboxed type corresponding to this Flow series element type.+convertUnboxed :: D.Type D.Name -> Maybe G.Type+convertUnboxed t+ | t == D.tNat = Just G.intPrimTy+ | t == D.tInt = Just G.intPrimTy+ | otherwise = Nothing+++-- Env ------------------------------------------------------------------------+-- | Environment used to map DDC names to GHC names.+-- Used when converting DDC Core to GHC core.+data Env+ = Env + { -- | Guts of the original GHC module.+ envGuts :: G.ModGuts++ -- | Table of Repa primitives+ , envPrimitives :: Primitives++ -- | Name map we got during the original GHC -> DDC conversion.+ , envNames :: Map D.Name GhcName++ -- | Locally scoped variables.+ , envVars :: [(D.Name, G.Var)]+ }+++-- | Bind a fresh GHC variable for a DDC expression variable.+bindVarX :: Env -> Env -> D.Bind D.Name -> G.UniqSM (Env, G.Var)+bindVarX kenv tenv (D.BName n t)+ = do gt <- convertType kenv t+ let str = D.renderPlain (D.ppr n)+ gv <- newDummyVar str gt+ let tenv' = tenv { envVars = (n, gv) : envVars tenv }+ return (tenv', gv)++bindVarX kenv tenv (D.BNone t)+ = do gt <- convertType kenv t+ gv <- newDummyVar "x" gt+ return (tenv, gv)++bindVarX _ _ b+ = error $ "repa-plugin.ToGHC.bindVarX: can't bind " ++ show b++++-- | Bind a fresh GHC type variable for a DDC type variable.+bindVarT :: Env -> D.Bind D.Name -> G.UniqSM (Env, G.Var)+bindVarT kenv (D.BName n _)+ = do let str = D.renderPlain (D.ppr n)+ gv <- newDummyTyVar str + let kenv' = kenv { envVars = (n, gv) : envVars kenv }+ return (kenv', gv)++bindVarT _ b+ = error $ "repa-plugin.ToGHC.bindVarT: can't bind " ++ show b+
+ Data/Array/Repa/Plugin/ToGHC/Var.hs view
@@ -0,0 +1,57 @@++module Data.Array.Repa.Plugin.ToGHC.Var+ ( plainNameOfVar+ , newDummyVar+ , newDummyExportedVar+ , newDummyTyVar)+where+import qualified Type as G+import qualified IdInfo as G+import qualified Var as G+import qualified UniqSupply as G+import qualified FastString as G+import qualified OccName as Occ+import qualified Name as Name+++-- Variable utils -------------------------------------------------------------+-- | Take the plain unqualified printable name of a GHC variable.+plainNameOfVar :: G.Var -> String+plainNameOfVar gv+ = let name = G.varName gv+ occ = Name.nameOccName name+ in Occ.occNameString occ+++-- | Create a fresh dummy GHC expression variable with the given type.+newDummyExportedVar :: String -> G.Type -> G.UniqSM G.Var+newDummyExportedVar basename ty+ = do let details = G.VanillaId+ let occName = Occ.mkOccName Occ.varName basename+ unique <- G.getUniqueUs+ let name = Name.mkSystemName unique occName+ let info = G.vanillaIdInfo+ return $ G.mkExportedLocalVar details name ty info+++-- | Create a fresh dummy GHC expression variable with the given type.+newDummyVar :: String -> G.Type -> G.UniqSM G.Var+newDummyVar basename ty+ = do let details = G.VanillaId+ let occName = Occ.mkOccName Occ.varName basename+ unique <- G.getUniqueUs+ let name = Name.mkSystemName unique occName+ let info = G.vanillaIdInfo+ return $ G.mkLocalVar details name ty info+++-- | Create a fresh dummy GHC type variable with the given type.+newDummyTyVar :: String -> G.UniqSM G.Var+newDummyTyVar basename+ = do unique <- G.getUniqueUs+ let name = Name.mkSysTvName unique (G.fsLit basename)+ return $ G.mkTyVar name G.liftedTypeKind++++
+ Data/Array/Repa/Plugin/ToGHC/Wrap.hs view
@@ -0,0 +1,215 @@++module Data.Array.Repa.Plugin.ToGHC.Wrap+ ( wrapLowered+ , unwrapResult)+where+import Data.Array.Repa.Plugin.ToGHC.Var+import Data.Array.Repa.Plugin.GHC.Pretty ()++import qualified BasicTypes as G+import qualified CoreSyn as G+import qualified DataCon as G+import qualified Type as G+import qualified TypeRep as G+import qualified TysPrim as G+import qualified TysWiredIn as G+import qualified MkId as G+import qualified UniqSupply as G+import Control.Monad+++-- | Make a wrapper to call a lowered version of a function from the original+-- binding. We need to unsafely pass it the world token, as well as marshall+-- between boxed and unboxed types.+wrapLowered + :: G.Type -- ^ Type of original version.+ -> G.Type -- ^ Type of lowered version.+ -> [Either G.Var G.CoreExpr] -- ^ Lambda bound variables in wrapper.+ -> G.Var -- ^ Name of lowered version.+ -> G.UniqSM G.CoreExpr++wrapLowered tOrig tLowered vsParam vLowered+ -- Decend into foralls.+ -- Bind the type argument with a new var so we can pass it to + -- the lowered function.+ | G.ForAllTy vOrig tOrig' <- tOrig+ , G.ForAllTy _ tLowered' <- tLowered+ = do let vsParam' = Left vOrig : vsParam+ xBody <- wrapLowered tOrig' tLowered' vsParam' vLowered+ return $ G.Lam vOrig xBody+++ -- If the type of the lowered function says it needs + -- the realworld token, then just give it one.+ -- This effectively unsafePerformIOs it.+ | G.FunTy tLowered1 tLowered2 <- tLowered+ , G.TyConApp tcState _ <- tLowered1+ , tcState == G.statePrimTyCon+ = do let vsParam' = Right (G.Var G.realWorldPrimId) : vsParam+ wrapLowered tOrig tLowered2 vsParam' vLowered+++ -- Descend into functions.+ -- Bind the argument with a new var so we can pass it to the lowered+ -- function.+ | G.FunTy tOrig1 tOrig2 <- tOrig+ , G.FunTy tLowered1 tLowered2 <- tLowered+ = do v' <- newDummyVar "arg" tOrig1+ -- Convert from type 'tOrig1' to 'tLowered1'+ arg' <- unwrapResult tLowered1 tOrig1 (G.Var v')+ let vsParam' = Right arg' : vsParam+ xBody <- wrapLowered tOrig2 tLowered2 vsParam' vLowered+ return $ G.Lam v' xBody+++ -- We've decended though all the foralls and lambdas and now need+ -- to call the actual lowered function, and marshall its result.+ | otherwise+ = do -- Arguments to pass to the lowered function.+ let xsArg = map (either (G.Type . G.TyVarTy) id) + vsParam++ -- Actual call to the lowered function.+ let xLowered = foldl G.App (G.Var vLowered) $ reverse xsArg++ callLowered tOrig tLowered xLowered+++-- | Make the call site for the lowered function.+callLowered+ :: G.Type -- ^ Type of result for original unlowered version.+ -> G.Type -- ^ Type of result for lowered version.+ -> G.CoreExpr -- ^ Exp that calls the lowered version.+ -> G.UniqSM G.CoreExpr++callLowered tOrig tLowered xLowered++ -- Assume this function returns a (# World#, ts.. #) -- TODO: check this.+ | G.TyConApp _ (_tWorld : tsVal) <- tLowered+ = do+ vScrut <- newDummyVar "scrut" tLowered+ vWorld <- newDummyVar "world" G.realWorldStatePrimTy+ vsVal <- zipWithM (\i t -> newDummyVar ("val" ++ show i) t)+ [0 :: Int ..] tsVal++ -- Unwrap the actual result value.+ let tOrigVal = tOrig+ let tsLoweredVal = tsVal+ xResult <- unwrapResultBits + tOrigVal + tsLoweredVal + (map G.Var vsVal)++ return $ G.Case xLowered vScrut tOrig + [ (G.DataAlt (G.tupleCon G.UnboxedTuple (1 + length tsVal))+ , (vWorld : vsVal)+ , xResult) ]++ | otherwise+ = error "repa-plugin.Wrap.callLowered: no match"+++unwrapResultBits+ :: G.Type -- ^ Type of result for original version.+ -> [G.Type] -- ^ Types of arguments lowered arguments+ -> [G.CoreExpr] -- ^ Types of components+ -> G.UniqSM G.CoreExpr++unwrapResultBits tOrig tsBits xsBits+ | [tBit] <- tsBits+ , [xBit] <- xsBits+ = unwrapResult tOrig tBit xBit ++ | G.TyConApp tcTup tsOrig <- tOrig+ , n <- length tsOrig+ , G.tupleTyCon G.BoxedTuple n == tcTup+ = do + xsResult <- mapM (\(tOrig', tLowered, xBit) + -> unwrapResult tOrig' tLowered xBit)+ $ zip3 tsOrig tsBits xsBits++ return $ G.mkConApp (G.tupleCon G.BoxedTuple n)+ (map G.Type tsOrig ++ xsResult)++ | otherwise+ = error "unwrapResultBits: failed"+++unwrapResult + :: G.Type -- ^ Type of result for original unlowered version.+ -> G.Type -- ^ Type of result for lowered version.+ -> G.CoreExpr -- ^ Expression for result value.+ -> G.UniqSM G.CoreExpr++unwrapResult tOrig tLowered xResult++ | G.TyConApp tcInt [] <- tOrig+ , tcInt == G.intTyCon+ , G.TyConApp tcIntU [] <- tLowered + , tcIntU == G.intPrimTyCon+ -- TODO: do a proper check. + -- Is this supposed to be a TyLit? ++ = return $ G.App (G.Var (G.dataConWorkId G.intDataCon)) xResult++ | G.TyConApp tcIntU [] <- tOrig+ , tcIntU == G.intPrimTyCon+ , G.TyConApp tcInt [] <- tLowered + , tcInt == G.intTyCon+ = do+ -- Case on the int constructor+ vScrut <- newDummyVar "scrut" tLowered+ v <- newDummyVar "v" tOrig+ return $ G.Case xResult vScrut tOrig+ [ (G.DataAlt G.intDataCon+ , [v]+ , G.Var v)]++ -- Original is a boxed tuple and lowered version is unboxed:+ -- raise to a boxed tuple, boxing its elements too.+ | G.TyConApp tcTup tins <- tOrig+ , G.TyConApp tcUnb touts <- tLowered + , n <- length tins+ , G.tupleTyCon G.BoxedTuple n == tcTup+ , G.tupleTyCon G.UnboxedTuple n == tcUnb+ = do+ -- Case on the unboxed tuple, raise the elements, then create a boxed tuple+ vScrut <- newDummyVar "scrut" tLowered+ vs <- mapM (newDummyVar "v") touts++ let unwrap (t,t',v)+ = unwrapResult t t' (G.Var v)++ xs <- mapM unwrap (zip3 tins touts vs)++ return (G.Case xResult vScrut tOrig+ [ (G.DataAlt (G.tupleCon G.UnboxedTuple n)+ , vs,+ G.mkConApp (G.tupleCon G.BoxedTuple n)+ (map G.Type tins ++ xs))])++ -- Convert boxed tuple to unboxed, maybe unbox its elements too+ | G.TyConApp tcUnb tins <- tOrig+ , G.TyConApp tcTup touts <- tLowered + , n <- length tins+ , G.tupleTyCon G.UnboxedTuple n == tcUnb+ , G.tupleTyCon G.BoxedTuple n == tcTup+ = do+ -- Case on the unboxed tuple, raise the elements, then create a boxed tuple+ vScrut <- newDummyVar "scrut" tLowered+ vs <- mapM (newDummyVar "v") touts++ let unwrap (t,t',v)+ = unwrapResult t t' (G.Var v)++ xs <- mapM unwrap (zip3 tins touts vs)++ return (G.Case xResult vScrut tOrig+ [ (G.DataAlt (G.tupleCon G.BoxedTuple n)+ , vs,+ G.mkConApp (G.tupleCon G.UnboxedTuple n)+ (map G.Type tins ++ xs))])+++ | otherwise+ = return xResult
+ LICENSE view
@@ -0,0 +1,36 @@+Copyright (c) 2001-2013, The DPH Team++The DPH Team is:+ Manuel M T Chakravarty+ Gabriele Keller+ Roman Leshchinskiy+ Ben Lippmeier+ George Roldugin+ Amos Robinson++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.++- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ repa-plugin.cabal view
@@ -0,0 +1,69 @@+Name: repa-plugin+Version: 1.0.0.1+License: BSD3+License-File: LICENSE+Cabal-Version: >= 1.10+Build-Type: Simple+Author: The DPH Team+Maintainer: Ben Lippmeier <benl@ouroborus.net>+Category: Data Structures+Synopsis: Data Flow Fusion GHC Plugin.+Description: + This GHC plugin implements Data Flow Fusion as described in the paper:+ Data Flow Fusion with Series Expressions in Haskell, Haskell Symposium 2013.++Library+ Exposed-Modules:+ Data.Array.Repa.Plugin++ Other-Modules:+ Data.Array.Repa.Plugin.FatName+ Data.Array.Repa.Plugin.Primitives+ Data.Array.Repa.Plugin.GHC.Pretty++ Data.Array.Repa.Plugin.ToDDC.Convert.Base+ Data.Array.Repa.Plugin.ToDDC.Convert.Type+ Data.Array.Repa.Plugin.ToDDC.Convert.Var+ Data.Array.Repa.Plugin.ToDDC.Convert+ Data.Array.Repa.Plugin.ToDDC.Detect.Base+ Data.Array.Repa.Plugin.ToDDC.Detect.Type+ Data.Array.Repa.Plugin.ToDDC.Detect+ Data.Array.Repa.Plugin.ToDDC++ Data.Array.Repa.Plugin.ToGHC.Prim+ Data.Array.Repa.Plugin.ToGHC.Wrap+ Data.Array.Repa.Plugin.ToGHC.Type+ Data.Array.Repa.Plugin.ToGHC.Var+ Data.Array.Repa.Plugin.ToGHC++ Data.Array.Repa.Plugin.Pass.Dump+ Data.Array.Repa.Plugin.Pass.Lower++ Data.Array.Repa.Plugin.Pipeline++ Build-Depends:+ base == 4.6.*,+ containers == 0.5.*,+ mtl == 2.1.*,+ ghc == 7.6.*,+ ddc-base == 0.3.2.*,+ ddc-core == 0.3.2.*,+ ddc-core-flow == 0.3.2.*,+ ddc-core-simpl == 0.3.2.*+++ Default-Language:+ Haskell2010++ Default-Extensions:+ TypeSynonymInstances+ KindSignatures+ BangPatterns+ FlexibleInstances++ GHC-options:+ -Wall+ -fno-warn-orphans+ -fno-warn-missing-signatures+ -fno-warn-unused-do-bind+