diff --git a/Data/Array/Repa/Plugin.hs b/Data/Array/Repa/Plugin.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Repa/Plugin.hs @@ -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. +-- +-- +-- +-- 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: +-- +-- +-- 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) + diff --git a/Data/Array/Repa/Plugin/FatName.hs b/Data/Array/Repa/Plugin/FatName.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Repa/Plugin/FatName.hs @@ -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 + diff --git a/Data/Array/Repa/Plugin/GHC/Pretty.hs b/Data/Array/Repa/Plugin/GHC/Pretty.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Repa/Plugin/GHC/Pretty.hs @@ -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 "" + + -- 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 "" + + +-- Type ----------------------------------------------------------------------- +instance Pretty TyLit where + ppr _ = text "" + +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 diff --git a/Data/Array/Repa/Plugin/Pass/Dump.hs b/Data/Array/Repa/Plugin/Pass/Dump.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Repa/Plugin/Pass/Dump.hs @@ -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) diff --git a/Data/Array/Repa/Plugin/Pass/Lower.hs b/Data/Array/Repa/Plugin/Pass/Lower.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Repa/Plugin/Pass/Lower.hs @@ -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 ] ] + diff --git a/Data/Array/Repa/Plugin/Pipeline.hs b/Data/Array/Repa/Plugin/Pipeline.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Repa/Plugin/Pipeline.hs @@ -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 + + diff --git a/Data/Array/Repa/Plugin/Primitives.hs b/Data/Array/Repa/Plugin/Primitives.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Repa/Plugin/Primitives.hs @@ -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 + diff --git a/Data/Array/Repa/Plugin/ToDDC.hs b/Data/Array/Repa/Plugin/ToDDC.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Repa/Plugin/ToDDC.hs @@ -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 diff --git a/Data/Array/Repa/Plugin/ToDDC/Convert.hs b/Data/Array/Repa/Plugin/ToDDC/Convert.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Repa/Plugin/ToDDC/Convert.hs @@ -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 + diff --git a/Data/Array/Repa/Plugin/ToDDC/Convert/Base.hs b/Data/Array/Repa/Plugin/ToDDC/Convert/Base.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Repa/Plugin/ToDDC/Convert/Base.hs @@ -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] diff --git a/Data/Array/Repa/Plugin/ToDDC/Convert/Type.hs b/Data/Array/Repa/Plugin/ToDDC/Convert/Type.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Repa/Plugin/ToDDC/Convert/Type.hs @@ -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)))) + + diff --git a/Data/Array/Repa/Plugin/ToDDC/Convert/Var.hs b/Data/Array/Repa/Plugin/ToDDC/Convert/Var.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Repa/Plugin/ToDDC/Convert/Var.hs @@ -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 + diff --git a/Data/Array/Repa/Plugin/ToDDC/Detect.hs b/Data/Array/Repa/Plugin/ToDDC/Detect.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Repa/Plugin/ToDDC/Detect.hs @@ -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) + diff --git a/Data/Array/Repa/Plugin/ToDDC/Detect/Base.hs b/Data/Array/Repa/Plugin/ToDDC/Detect/Base.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Repa/Plugin/ToDDC/Detect/Base.hs @@ -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 diff --git a/Data/Array/Repa/Plugin/ToDDC/Detect/Type.hs b/Data/Array/Repa/Plugin/ToDDC/Detect/Type.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Repa/Plugin/ToDDC/Detect/Type.hs @@ -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' + diff --git a/Data/Array/Repa/Plugin/ToGHC.hs b/Data/Array/Repa/Plugin/ToGHC.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Repa/Plugin/ToGHC.hs @@ -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 ] + diff --git a/Data/Array/Repa/Plugin/ToGHC/Prim.hs b/Data/Array/Repa/Plugin/ToGHC/Prim.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Repa/Plugin/ToGHC/Prim.hs @@ -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." ] + diff --git a/Data/Array/Repa/Plugin/ToGHC/Type.hs b/Data/Array/Repa/Plugin/ToGHC/Type.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Repa/Plugin/ToGHC/Type.hs @@ -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 + diff --git a/Data/Array/Repa/Plugin/ToGHC/Var.hs b/Data/Array/Repa/Plugin/ToGHC/Var.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Repa/Plugin/ToGHC/Var.hs @@ -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 + + + + diff --git a/Data/Array/Repa/Plugin/ToGHC/Wrap.hs b/Data/Array/Repa/Plugin/ToGHC/Wrap.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Repa/Plugin/ToGHC/Wrap.hs @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/repa-plugin.cabal b/repa-plugin.cabal new file mode 100644 --- /dev/null +++ b/repa-plugin.cabal @@ -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 +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 +