diff --git a/DDC/Core/Flow.hs b/DDC/Core/Flow.hs --- a/DDC/Core/Flow.hs +++ b/DDC/Core/Flow.hs @@ -6,11 +6,27 @@ ( -- * Language profile profile + -- * Driver + , Lifting (..) + , Config (..) + , defaultConfigVector + , defaultConfigKernel + , defaultConfigScalar + , Method (..) + , lowerModule + -- * Names , Name (..) + , KiConFlow (..) , TyConFlow (..) + , DaConFlow (..) + , OpControl (..) + , OpSeries (..) + , OpStore (..) + , OpVector (..) , PrimTyCon (..) , PrimArith (..) + , PrimVec (..) , PrimCast (..) -- * Name Parsing @@ -23,3 +39,4 @@ where import DDC.Core.Flow.Prim import DDC.Core.Flow.Profile +import DDC.Core.Flow.Lower diff --git a/DDC/Core/Flow/Compounds.hs b/DDC/Core/Flow/Compounds.hs --- a/DDC/Core/Flow/Compounds.hs +++ b/DDC/Core/Flow/Compounds.hs @@ -7,12 +7,19 @@ , kRate -- * Fragment specific types + , isRateNatType + , isSeriesType + , isRefType + , isVectorType , tTuple1, tTuple2, tTupleN , tVector, tSeries, tSegd, tSel1, tSel2, tRef, tWorld , tRateNat + , tDown + , tTail + , tProcess -- * Primtiive types - , tVoid, tBool, tNat, tInt, tWord + , tVoid, tBool, tNat, tInt, tWord, tFloat, tVec -- * Primitive literals and data constructors , xBool, dcBool @@ -21,25 +28,40 @@ , xTuple2, dcTuple2 , dcTupleN - -- * Flow operators + -- * Primitive Vec operators + , xvRep + , xvProj + , xvGather + , xvScatter + + -- * Series operators + , xProj , xRateOfSeries , xNatOfRateNat + , xNext, xNextC + , xDown + , xTail - -- * Loop operators - , xLoopLoopN - , xLoopGuard + -- * Control operators + , xLoopN + , xGuard + , xSegment + , xSplit -- * Store operators - , xNew, xRead, xWrite - , xNewVector, xReadVector, xWriteVector, xNewVectorR, xNewVectorN - , xSliceVector - , xNext) + , xNew, xRead, xWrite + , xNewVector, xNewVectorR, xNewVectorN + , xReadVector, xReadVectorC + , xWriteVector, xWriteVectorC + , xTailVector + , xTruncVector) where import DDC.Core.Flow.Prim.KiConFlow import DDC.Core.Flow.Prim.TyConFlow import DDC.Core.Flow.Prim.TyConPrim import DDC.Core.Flow.Prim.DaConPrim -import DDC.Core.Flow.Prim.OpFlow -import DDC.Core.Flow.Prim.OpLoop +import DDC.Core.Flow.Prim.OpControl +import DDC.Core.Flow.Prim.OpConcrete import DDC.Core.Flow.Prim.OpStore +import DDC.Core.Flow.Prim.OpPrim import DDC.Core.Compounds.Simple diff --git a/DDC/Core/Flow/Context.hs b/DDC/Core/Flow/Context.hs --- a/DDC/Core/Flow/Context.hs +++ b/DDC/Core/Flow/Context.hs @@ -11,11 +11,19 @@ = ContextRate { contextRate :: Type Name } - -- | A nested context created by a mkSel function. + -- | A nested context created by a mkSel1# function. | ContextSelect { contextOuterRate :: Type Name , contextInnerRate :: Type Name , contextFlags :: Bound Name , contextSelector :: Bind Name } + + + -- | A nested context created by a mkSegd# function. + | ContextSegment + { contextOuterRate :: Type Name + , contextInnerRate :: Type Name + , contextLens :: Bound Name + , contextSegd :: Bind Name } deriving (Show, Eq) diff --git a/DDC/Core/Flow/Env.hs b/DDC/Core/Flow/Env.hs --- a/DDC/Core/Flow/Env.hs +++ b/DDC/Core/Flow/Env.hs @@ -32,52 +32,57 @@ primDataDefs :: DataDefs Name primDataDefs = fromListDataDefs - -- Primitive ----------------------------------------------- - $ -- Bool# - [ DataDef (NamePrimTyCon PrimTyConBool) + $ -- Primitive ----------------------------------------------- + -- Bool# + [ makeDataDefAlg (NamePrimTyCon PrimTyConBool) [] (Just [ (NameLitBool True, []) , (NameLitBool False, []) ]) -- Nat# - , DataDef (NamePrimTyCon PrimTyConNat) [] Nothing + , makeDataDefAlg (NamePrimTyCon PrimTyConNat) [] Nothing -- Int# - , DataDef (NamePrimTyCon PrimTyConInt) [] Nothing + , makeDataDefAlg (NamePrimTyCon PrimTyConInt) [] Nothing + -- Float32# + , makeDataDefAlg (NamePrimTyCon (PrimTyConFloat 32)) [] Nothing + + -- Float64# + , makeDataDefAlg (NamePrimTyCon (PrimTyConFloat 64)) [] Nothing + -- WordN# - , DataDef (NamePrimTyCon (PrimTyConWord 64)) [] Nothing - , DataDef (NamePrimTyCon (PrimTyConWord 32)) [] Nothing - , DataDef (NamePrimTyCon (PrimTyConWord 16)) [] Nothing - , DataDef (NamePrimTyCon (PrimTyConWord 8)) [] Nothing + , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 64)) [] Nothing + , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 32)) [] Nothing + , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 16)) [] Nothing + , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 8)) [] Nothing -- Flow ----------------------------------------------------- - -- Vector - , DataDef + , makeDataDefAbs (NameTyConFlow TyConFlowVector) - [kRate, kData] - (Just []) + [BAnon kRate, BAnon kData] -- Series - , DataDef + , makeDataDefAbs (NameTyConFlow TyConFlowSeries) - [kRate, kData] - (Just []) + [BAnon kRate, BAnon kData] ] -- Tuple -- Hard-code maximum tuple arity to 32. - ++ [ makeTupleDataDef arity | arity <- [2..32] ] + -- We don't have a way of avoiding the upper bound. + ++ [ makeTupleDataDef arity + | arity <- [2..32] ] -- | Make a tuple data def for the given tuple arity. makeTupleDataDef :: Int -> DataDef Name makeTupleDataDef n - = DataDef + = makeDataDefAlg (NameTyConFlow (TyConFlowTuple n)) - (replicate n kData) + (replicate n (BAnon kData)) (Just [ ( NameDaConFlow (DaConFlowTuple n) , (reverse [tIx kData i | i <- [0..n - 1]]))]) @@ -123,18 +128,22 @@ typeOfPrimName :: Name -> Maybe (Type Name) typeOfPrimName dc = case dc of - NameOpFlow p -> Just $ typeOpFlow p - NameOpLoop p -> Just $ typeOpLoop p - NameOpStore p -> Just $ typeOpStore p - NameDaConFlow p -> Just $ typeDaConFlow p + NameOpConcrete p -> Just $ typeOpConcrete p + NameOpSeries p -> Just $ typeOpSeries p + NameOpStore p -> Just $ typeOpStore p + NameOpControl p -> Just $ typeOpControl p + NameOpVector p -> Just $ typeOpVector p + NameDaConFlow p -> Just $ typeDaConFlow p - NamePrimCast p -> Just $ typePrimCast p - NamePrimArith p -> Just $ typePrimArith p + NamePrimCast p -> Just $ typePrimCast p + NamePrimArith p -> Just $ typePrimArith p + NamePrimVec p -> Just $ typePrimVec p - NameLitBool _ -> Just $ tBool - NameLitNat _ -> Just $ tNat - NameLitInt _ -> Just $ tInt - NameLitWord _ bits -> Just $ tWord bits + NameLitBool _ -> Just $ tBool + NameLitNat _ -> Just $ tNat + NameLitInt _ -> Just $ tInt + NameLitWord _ bits -> Just $ tWord bits + NameLitFloat _ bits -> Just $ tFloat bits _ -> Nothing diff --git a/DDC/Core/Flow/Exp.hs b/DDC/Core/Flow/Exp.hs --- a/DDC/Core/Flow/Exp.hs +++ b/DDC/Core/Flow/Exp.hs @@ -33,3 +33,5 @@ type BoundF = Bound Name type BindF = Bind Name + + diff --git a/DDC/Core/Flow/Lower.hs b/DDC/Core/Flow/Lower.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Lower.hs @@ -0,0 +1,292 @@ + + +module DDC.Core.Flow.Lower + ( Config (..) + , defaultConfigScalar + , defaultConfigKernel + , defaultConfigVector + , Method (..) + , Lifting (..) + , lowerModule) +where +import DDC.Core.Flow.Transform.Slurp +import DDC.Core.Flow.Transform.Schedule +import DDC.Core.Flow.Transform.Schedule.Base +import DDC.Core.Flow.Transform.Extract +import DDC.Core.Flow.Process +import DDC.Core.Flow.Procedure +import DDC.Core.Flow.Compounds +import DDC.Core.Flow.Profile +import DDC.Core.Flow.Prim +import DDC.Core.Flow.Exp +import DDC.Core.Module + +import DDC.Core.Transform.Annotate + +import qualified DDC.Core.Simplifier as C +import qualified DDC.Core.Simplifier.Recipe as C +import qualified DDC.Core.Transform.Namify as C +import qualified DDC.Core.Transform.Snip as Snip +import qualified DDC.Type.Env as Env +import qualified Control.Monad.State.Strict as S +import qualified Data.Monoid as M +import Control.Monad + + +-- | Configuration for the lower transform. +data Config + = Config + { configMethod :: Method } + deriving (Eq, Show) + + +-- | What lowering method to use. +data Method + -- | Produce sequential scalar code with nested loops. + = MethodScalar + + -- | Produce vector kernel code that only processes an even multiple + -- of the vector width. + | MethodKernel + { methodLifting :: Lifting } + + -- | Try to produce sequential vector code, + -- falling back to scalar code if this is not possible. + | MethodVector + { methodLifting :: Lifting } + deriving (Eq, Show) + + +-- | Config for producing code with just scalar operations. +defaultConfigScalar :: Config +defaultConfigScalar + = Config + { configMethod = MethodScalar } + + +-- | Config for producing code with vector operations, +-- where the loops just handle a size of data which is an even multiple +-- of the vector width. +defaultConfigKernel :: Config +defaultConfigKernel + = Config + { configMethod = MethodKernel (Lifting 8)} + + +-- | Config for producing code with vector operations, +-- where the loops handle arbitrary data sizes, of any number of elements. +defaultConfigVector :: Config +defaultConfigVector + = Config + { configMethod = MethodVector (Lifting 8)} + + +-- Lower ---------------------------------------------------------------------- +-- | Take a module that contains only well formed series processes defined +-- at top-level, and lower them all into procedures. +lowerModule :: Config -> ModuleF -> Either Error ModuleF +lowerModule config mm + = case slurpProcesses mm of + -- Can't slurp a process definition from one of the top level series + -- processes. + Left err + -> Left (ErrorSlurpError err) + + -- We've got a process definition for all of then. + Right procs + -> do + -- Schedule the processeses into procedures. + lets <- mapM (lowerProcess config) procs + + -- Wrap all the procedures into a new module. + let mm_lowered = mm + { moduleBody = annotate () + $ XLet (LRec lets) xUnit } + + -- Clean up extracted code + let mm_clean = cleanModule mm_lowered + return mm_clean + + +-- | Lower a single series process into fused code. +lowerProcess :: Config -> Process -> Either Error (BindF, ExpF) +lowerProcess config process + + -- Scalar lowering ------------------------------ + | MethodScalar <- configMethod config + = do + -- Schedule process into scalar code. + let Right proc = scheduleScalar process + + -- Extract code for the kernel + let (bProc, xProc) = extractProcedure proc + + return (bProc, xProc) + + + -- Vector lowering ----------------------------- + -- To use the vector method, + -- the type of the source function needs to have a quantifier for + -- the rate variable (k), as well as a (RateNat k) witness. + -- + | MethodVector lifting <- configMethod config + , [nRN] <- [ nRN | BName nRN tRN <- processParamValues process + , isRateNatType tRN ] + , bK : _ <- processParamTypes process + = do let c = liftingFactor lifting + + -- Get the primary rate variable. + let Just uK = takeSubstBoundOfBind bK + let tK = TVar uK + + -- The RateNat witness + let xRN = XVar (UName nRN) + + ----------------------------------------- + -- Create the vector version of the kernel. + -- Vector code processes several elements per loop iteration. + procVec <- scheduleKernel lifting process + let (_, xProcVec) = extractProcedure procVec + + + let bxsDownSeries + = [ ( bS + , ( BName (NameVarMod n "down") + (tSeries (tDown c tK) tE) + , xDown c tK tE (XVar (UIx 0)) xS)) + | bS@(BName n tS) <- processParamValues process + , let Just tE = elemTypeOfSeriesType tS + , let Just uS = takeSubstBoundOfBind bS + , let xS = XVar uS + , isSeriesType tS ] + + -- Get a value arg to give to the vector procedure. + let getDownValArg b + | Just (b', _) <- lookup b bxsDownSeries + = liftM XVar $ takeSubstBoundOfBind b' + + | otherwise + = liftM XVar $ takeSubstBoundOfBind b + + let Just xsVecValArgs + = sequence + $ map getDownValArg (processParamValues process) + + let bRateDown + = BAnon (tRateNat (tDown c (TVar uK))) + + let xProcVec' + = XLam bRateDown + $ xLets [LLet b x | (_, (b, x)) <- bxsDownSeries] + $ xApps (XApp xProcVec (XType (TVar uK))) + $ xsVecValArgs + + + ----------------------------------------- + -- Create tail version. + -- Scalar code processes the final elements of the loop. + procTail <- scheduleScalar process + let (bProcTail, xProcTail) = extractProcedure procTail + + -- Window the input series to select the tails. + let bxsTailSeries + = [ ( bS, ( BName (NameVarMod n "tail") (tSeries (tTail c tK) tE) + , xTail c tK tE (XVar (UIx 0)) xS)) + | bS@(BName n tS) <- processParamValues process + , let Just tE = elemTypeOfSeriesType tS + , let Just uS = takeSubstBoundOfBind bS + , let xS = XVar uS + , isSeriesType tS ] + + -- Window the output vectors to select the tails. + let bxsTailVector + = [ ( bV, ( BName (NameVarMod n "tail") (tVector tE) + , xTailVector c tK tE (XVar (UIx 0)) xV)) + | bV@(BName n tV) <- processParamValues process + , let Just tE = elemTypeOfVectorType tV + , let Just uV = takeSubstBoundOfBind bV + , let xV = XVar uV + , isVectorType tV ] + + -- Get a value arg to give to the scalar procedure. + let getTailValArg b + | Just (b', _) <- lookup b bxsTailSeries + = liftM XVar $ takeSubstBoundOfBind b' + + | Just (b', _) <- lookup b bxsTailVector + = liftM XVar $ takeSubstBoundOfBind b' + + | otherwise + = liftM XVar $ takeSubstBoundOfBind b + + let Just xsTailValArgs + = sequence + $ map getTailValArg (procedureParamValues procTail) + + let bRateTail + = BAnon (tRateNat (tTail c (TVar uK))) + + let xProcTail' + = XLam bRateTail + $ xLets [LLet b x | (_, (b, x)) <- bxsTailSeries] + $ xLets [LLet b x | (_, (b, x)) <- bxsTailVector] + $ xApps (XApp xProcTail (XType (tTail c (TVar uK)))) + $ xsTailValArgs + + ------------------------------------------ + -- Stich the vector and scalar versions together. + let xProc + = foldr XLAM + (foldr XLam xBody (processParamValues process)) + (processParamTypes process) + + xBody + = XLet (LLet (BNone tUnit) + (xSplit c (TVar uK) xRN xProcVec' xProcTail')) + xUnit + + -- Reconstruct a binder for the whole procedure / process. + let bProc + = BName (processName process) + (typeOfBind bProcTail) + + return (bProc, xProc) + + -- Kernel lowering ----------------------------- + | MethodKernel lifting <- configMethod config + = do + -- Schedule process into + proc <- scheduleKernel lifting process + + -- Extract code for the kernel + let (bProc, xProc) = extractProcedure proc + + return (bProc, xProc) + + | otherwise + = error $ "ddc-core-flow.lowerProcess: invalid lowering method" + + +-- Clean ---------------------------------------------------------------------- +-- | Do some beta-reductions to ensure that arguments to worker functions +-- are inlined, then normalize nested applications. +-- When snipping, leave lambda abstractions in place so the worker functions +-- applied to our loop combinators aren't moved. +cleanModule :: ModuleF -> ModuleF +cleanModule mm + = let + clean + = C.Trans (C.Namify (C.makeNamifier freshT) + (C.makeNamifier freshX)) + M.<> C.Trans C.Forward + M.<> C.beta + M.<> C.Trans (C.Snip (Snip.configZero { Snip.configPreserveLambdas = True })) + M.<> C.Trans C.Flatten + + mm_cleaned + = C.result $ S.evalState + (C.applySimplifier profile Env.empty Env.empty + (C.Fix 4 clean) mm) + 0 + in mm_cleaned + diff --git a/DDC/Core/Flow/Prim.hs b/DDC/Core/Flow/Prim.hs --- a/DDC/Core/Flow/Prim.hs +++ b/DDC/Core/Flow/Prim.hs @@ -18,21 +18,31 @@ , readDaConFlow , typeDaConFlow - -- * Flow operators - , OpFlow (..) - , readOpFlow - , typeOpFlow + -- * Fusable Flow operators + , OpConcrete (..) + , readOpConcrete + , typeOpConcrete - -- * Loop operators - , OpLoop (..) - , readOpLoop - , typeOpLoop + -- * Series operators + , OpSeries (..) + , readOpSeries + , typeOpSeries + -- * Control operators + , OpControl (..) + , readOpControl + , typeOpControl + -- * Store operators , OpStore (..) , readOpStore , typeOpStore + -- * Store operators + , OpVector (..) + , readOpVector + , typeOpVector + -- * Primitive type constructors , PrimTyCon (..) , kindPrimTyCon @@ -41,6 +51,13 @@ , PrimArith (..) , typePrimArith + -- * Primitive vector operators + , PrimVec (..) + , typePrimVec + , multiOfPrimVec + , liftPrimArithToVec + , lowerPrimVecToArith + -- * Casting between primitive types , PrimCast (..) , typePrimCast) @@ -51,19 +68,29 @@ import DDC.Core.Flow.Prim.TyConPrim import DDC.Core.Flow.Prim.DaConFlow import DDC.Core.Flow.Prim.DaConPrim () -import DDC.Core.Flow.Prim.OpFlow -import DDC.Core.Flow.Prim.OpLoop +import DDC.Core.Flow.Prim.OpConcrete +import DDC.Core.Flow.Prim.OpControl +import DDC.Core.Flow.Prim.OpSeries import DDC.Core.Flow.Prim.OpStore +import DDC.Core.Flow.Prim.OpVector import DDC.Core.Flow.Prim.OpPrim -import DDC.Core.Salt.Name +import DDC.Core.Salt.Name ( readPrimTyCon - , readPrimCast + , readPrimArith + + , readPrimVec + , multiOfPrimVec + , liftPrimArithToVec + , lowerPrimVecToArith + + , readPrimCast , readLitPrimNat , readLitPrimInt - , readLitPrimWordOfBits) - + , readLitPrimWordOfBits + , readLitPrimFloatOfBits) + import DDC.Base.Pretty import Control.DeepSeq import Data.Char @@ -79,18 +106,22 @@ NameKiConFlow con -> rnf con NameTyConFlow con -> rnf con NameDaConFlow con -> rnf con - NameOpFlow op -> rnf op - NameOpLoop op -> rnf op + NameOpConcrete op -> rnf op + NameOpControl op -> rnf op + NameOpSeries op -> rnf op NameOpStore op -> rnf op + NameOpVector op -> rnf op - NamePrimTyCon con -> rnf con - NamePrimArith con -> rnf con - NamePrimCast c -> rnf c + NamePrimTyCon op -> rnf op + NamePrimArith op -> rnf op + NamePrimVec op -> rnf op + NamePrimCast op -> rnf op NameLitBool b -> rnf b NameLitNat n -> rnf n NameLitInt i -> rnf i NameLitWord i bits -> rnf i `seq` rnf bits + NameLitFloat r bits -> rnf r `seq` rnf bits instance Pretty Name where @@ -103,36 +134,43 @@ NameKiConFlow con -> ppr con NameTyConFlow con -> ppr con NameDaConFlow con -> ppr con - NameOpFlow op -> ppr op - NameOpLoop op -> ppr op + NameOpConcrete op -> ppr op + NameOpControl op -> ppr op + NameOpSeries op -> ppr op NameOpStore op -> ppr op + NameOpVector op -> ppr op NamePrimTyCon tc -> ppr tc NamePrimArith op -> ppr op + NamePrimVec op -> ppr op NamePrimCast op -> ppr op NameLitBool True -> text "True#" NameLitBool False -> text "False#" - NameLitNat i -> integer i <> text "#" - NameLitInt i -> integer i <> text "i" <> text "#" - NameLitWord i bits -> integer i <> text "w" <> int bits <> text "#" + NameLitNat i -> integer i <> text "#" + NameLitInt i -> integer i <> text "i" <> text "#" + NameLitWord i bits -> integer i <> text "w" <> int bits <> text "#" + NameLitFloat r bits -> double (fromRational r) <> text "f" <> int bits <> text "#" -- | Read the name of a variable, constructor or literal. readName :: String -> Maybe Name readName str -- Flow fragment specific names. - | Just p <- readKiConFlow str = Just $ NameKiConFlow p - | Just p <- readTyConFlow str = Just $ NameTyConFlow p - | Just p <- readDaConFlow str = Just $ NameDaConFlow p - | Just p <- readOpFlow str = Just $ NameOpFlow p - | Just p <- readOpLoop str = Just $ NameOpLoop p - | Just p <- readOpStore str = Just $ NameOpStore p + | Just p <- readKiConFlow str = Just $ NameKiConFlow p + | Just p <- readTyConFlow str = Just $ NameTyConFlow p + | Just p <- readDaConFlow str = Just $ NameDaConFlow p + | Just p <- readOpConcrete str = Just $ NameOpConcrete p + | Just p <- readOpControl str = Just $ NameOpControl p + | Just p <- readOpSeries str = Just $ NameOpSeries p + | Just p <- readOpStore str = Just $ NameOpStore p + | Just p <- readOpVector str = Just $ NameOpVector p -- Primitive names. - | Just p <- readPrimTyCon str = Just $ NamePrimTyCon p - | Just p <- readPrimArith str = Just $ NamePrimArith p - | Just p <- readPrimCast str = Just $ NamePrimCast p + | Just p <- readPrimTyCon str = Just $ NamePrimTyCon p + | Just p <- readPrimArith str = Just $ NamePrimArith p + | Just p <- readPrimVec str = Just $ NamePrimVec p + | Just p <- readPrimCast str = Just $ NamePrimCast p -- Literal Bools | str == "True#" = Just $ NameLitBool True @@ -147,9 +185,14 @@ = Just $ NameLitInt val -- Literal Words - | Just (val, bits) <- readLitPrimWordOfBits str + | Just (val, bits) <- readLitPrimWordOfBits str , elem bits [8, 16, 32, 64] = Just $ NameLitWord val bits + + -- Literal Floats + | Just (val, bits) <- readLitPrimFloatOfBits str + , elem bits [32, 64] + = Just $ NameLitFloat (toRational val) bits -- Variables. | c : _ <- str diff --git a/DDC/Core/Flow/Prim/Base.hs b/DDC/Core/Flow/Prim/Base.hs --- a/DDC/Core/Flow/Prim/Base.hs +++ b/DDC/Core/Flow/Prim/Base.hs @@ -4,17 +4,21 @@ , KiConFlow (..) , TyConFlow (..) , DaConFlow (..) - , OpFlow (..) - , OpLoop (..) + , OpConcrete (..) + , OpControl (..) + , OpSeries (..) , OpStore (..) + , OpVector (..) , PrimTyCon (..) , PrimArith (..) + , PrimVec (..) , PrimCast (..)) where import Data.Typeable -import DDC.Core.Salt.Name +import DDC.Core.Salt.Name ( PrimTyCon (..) , PrimArith (..) + , PrimVec (..) , PrimCast (..)) @@ -39,16 +43,22 @@ -- | Fragment specific data constructors. | NameDaConFlow DaConFlow - -- | Flow operators. - | NameOpFlow OpFlow + -- | Concrete series operators. + | NameOpConcrete OpConcrete - -- | Loop operators. - | NameOpLoop OpLoop + -- | Control operators. + | NameOpControl OpControl + -- | Series operators. + | NameOpSeries OpSeries + -- | Store operators. | NameOpStore OpStore + -- | Vector operators. + | NameOpVector OpVector + -- Machine primitives ------------------ -- | A primitive type constructor. | NamePrimTyCon PrimTyCon @@ -59,7 +69,10 @@ -- | Primitive casting between numeric types. | NamePrimCast PrimCast + -- | Primitive vector operators. + | NamePrimVec PrimVec + -- Literals ----------------------------- -- | A boolean literal. | NameLitBool Bool @@ -70,8 +83,11 @@ -- | An integer literal. | NameLitInt Integer - -- | A word literal. - | NameLitWord Integer Int + -- | A word literal, with the given number of bits precision. + | NameLitWord Integer Int + + -- | A float literal, with the given number of bits precision. + | NameLitFloat Rational Int deriving (Eq, Ord, Show, Typeable) @@ -98,14 +114,23 @@ -- | @SelN#@ constructor. Selectors. | TyConFlowSel Int - -- | @Ref#@ constructor. References. + -- | @Ref#@ constructor. References. | TyConFlowRef - -- | @World#@ constructor. State token used when converting to GHC core. + -- | @World#@ constructor. State token used when converting to GHC core. | TyConFlowWorld -- | @RateNat#@ constructor. Naturals witnessing a type-level Rate. | TyConFlowRateNat + + -- | @DownN#@ constructor. Rate decimation. + | TyConFlowDown Int + + -- | @TailN#@ constructor. Rate tail after decimation. + | TyConFlowTail Int + + -- | @Process@ constructor. + | TyConFlowProcess deriving (Eq, Ord, Show) @@ -116,49 +141,97 @@ deriving (Eq, Ord, Show) --- | Flow operators. -data OpFlow - -- series conversions. - = OpFlowVectorOfSeries - | OpFlowRateOfSeries - | OpFlowNatOfRateNat +-- | Fusable Flow operators that work on Series. +data OpSeries + -- | Replicate a single element into a series. + = OpSeriesRep - -- selectors - | OpFlowMkSel Int + -- | Segmented replicate. + | OpSeriesReps - -- maps - | OpFlowMap Int + -- | Segmented indices + | OpSeriesIndices - -- replicates - | OpFlowRep - | OpFlowReps + -- | Fill an existing vector from a series. + | OpSeriesFill - -- folds - | OpFlowFold - | OpFlowFoldIndex - | OpFlowFolds + -- | Gather (read) elements from a vector. + | OpSeriesGather - -- unfolds - | OpFlowUnfold - | OpFlowUnfolds + -- | Scatter (write) elements into a vector. + | OpSeriesScatter - -- split/combine - | OpFlowSplit Int - | OpFlowCombine Int + -- | Make a selector. + | OpSeriesMkSel Int - -- packing - | OpFlowPack + -- | Make a segment descriptor. + | OpSeriesMkSegd + + -- | Apply a worker to corresponding elements of some series. + | OpSeriesMap Int + + -- | Pack a series according to a flags vector. + | OpSeriesPack + + -- | Reduce a series with an associative operator, + -- updating an existing accumulator. + | OpSeriesReduce + + -- | Segmented fold. + | OpSeriesFolds + + -- | Convert vector(s) into series, all with same length with runtime check. + | OpSeriesRunProcess Int + + -- | Join two series processes. + | OpSeriesJoin deriving (Eq, Ord, Show) --- | Loop operators. -data OpLoop - = OpLoopLoop - | OpLoopLoopN - | OpLoopGuard +-- | Series related operators. +-- These operators work on series after the code has been fused. +-- They do not appear in the source program. +data OpConcrete + -- | Project out a component of a tuple, + -- given the tuple arity and index of the desired component. + = OpConcreteProj Int Int + + -- | Take the rate of a series. + | OpConcreteRateOfSeries + + -- | Take the underlying @Nat@ of a @RateNat@. + | OpConcreteNatOfRateNat + + -- | Take some elements from a series. + | OpConcreteNext Int + + -- | Decimate the rate of a series. + | OpConcreteDown Int + + -- | Take the tail rate of a decimated series. + | OpConcreteTail Int deriving (Eq, Ord, Show) +-- | Control operators. +data OpControl + -- Top level loop, indexed by a rate type. + = OpControlLoop + + -- Top level loop, taking a RateNat. + | OpControlLoopN + + -- Evaluate some function when a flag is true. + | OpControlGuard + + -- Evaluate some function a given number of times. + | OpControlSegment + + -- Used for producing SIMD code. + | OpControlSplit Int + deriving (Eq, Ord, Show) + + -- | Store operators. data OpStore -- Assignables ---------------- @@ -171,7 +244,6 @@ -- | Write to a reference. | OpStoreWrite - -- Vectors -------------------- -- | Allocate a new vector (taking a @Nat@ for the length) | OpStoreNewVector @@ -182,18 +254,35 @@ -- | Allocate a new vector (taking a @RateNat@ for the length) | OpStoreNewVectorN - -- | Read from a vector. - | OpStoreReadVector + -- | Read a packed Vec of values from a Vector buffer. + | OpStoreReadVector Int - -- | Write to a vector. - | OpStoreWriteVector + -- | Write a packed Vec of values to a Vector buffer. + | OpStoreWriteVector Int - -- | Slice after a pack/filter (taking a @Nat@ for new length) - | OpStoreSliceVector + -- | Window a target vector to the tail of some rate. + | OpStoreTailVector Int + -- | Truncate a vector to a smaller length. + | OpStoreTruncVector + deriving (Eq, Ord, Show) - -- Streams -------------------- - -- | Take the next element from a series. - | OpStoreNext + +-- | Fusable flow operators that work on Vectors. +data OpVector + -- | Apply worker function to @n@ vectors zipped. + = OpVectorMap Int + + -- | Filter a vector according to a predicate. + | OpVectorFilter + + -- | Associative fold. + | OpVectorReduce + + -- | Create a new vector from an index function. + | OpVectorGenerate + + -- | Get a vector's length. + | OpVectorLength deriving (Eq, Ord, Show) diff --git a/DDC/Core/Flow/Prim/DaConPrim.hs b/DDC/Core/Flow/Prim/DaConPrim.hs --- a/DDC/Core/Flow/Prim/DaConPrim.hs +++ b/DDC/Core/Flow/Prim/DaConPrim.hs @@ -15,12 +15,12 @@ -- | A literal @Bool#@ xBool :: Bool -> Exp a Name -xBool b = XCon (mkDaConAlg (NameLitBool b) tBool) +xBool b = XCon (dcBool b) -- | A literal @Bool#@ data constructor. dcBool :: Bool -> DaCon Name -dcBool b = mkDaConAlg (NameLitBool b) tBool +dcBool b = DaConPrim (NameLitBool b) tBool -- | A literal @Nat#@ @@ -30,13 +30,13 @@ -- | A Literal @Nat#@ data constructor. dcNat :: Integer -> DaCon Name -dcNat i = mkDaConAlg (NameLitInt i) tNat +dcNat i = DaConPrim (NameLitNat i) tNat -- | Data constructor for @Tuple1#@ dcTuple1 :: DaCon Name -dcTuple1 = mkDaConAlg (NameDaConFlow (DaConFlowTuple 1)) - $ typeDaConFlow (DaConFlowTuple 1) +dcTuple1 = DaConPrim (NameDaConFlow (DaConFlowTuple 1)) + (typeDaConFlow (DaConFlowTuple 1)) -- | Construct a @Tuple2#@ @@ -51,13 +51,13 @@ -- | Data constructor for @Tuple2#@ dcTuple2 :: DaCon Name -dcTuple2 = mkDaConAlg (NameDaConFlow (DaConFlowTuple 2)) - $ typeDaConFlow (DaConFlowTuple 2) +dcTuple2 = DaConPrim (NameDaConFlow (DaConFlowTuple 2)) + (typeDaConFlow (DaConFlowTuple 2)) -- | Data constructor for n-tuples dcTupleN :: Int -> DaCon Name dcTupleN n - = mkDaConAlg (NameDaConFlow (DaConFlowTuple n)) - $ typeDaConFlow (DaConFlowTuple n) + = DaConPrim (NameDaConFlow (DaConFlowTuple n)) + (typeDaConFlow (DaConFlowTuple n)) diff --git a/DDC/Core/Flow/Prim/OpConcrete.hs b/DDC/Core/Flow/Prim/OpConcrete.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Prim/OpConcrete.hs @@ -0,0 +1,191 @@ + +module DDC.Core.Flow.Prim.OpConcrete + ( readOpConcrete + , typeOpConcrete + + -- * Compounds + , xProj + , xRateOfSeries + , xNatOfRateNat + , xNext + , xNextC + + , xDown + , xTail) +where +import DDC.Core.Flow.Prim.KiConFlow +import DDC.Core.Flow.Prim.TyConFlow +import DDC.Core.Flow.Prim.TyConPrim +import DDC.Core.Flow.Prim.Base +import DDC.Core.Compounds.Simple +import DDC.Core.Exp.Simple +import DDC.Base.Pretty +import Control.DeepSeq +import Data.List +import Data.Char + + +instance NFData OpConcrete + + +instance Pretty OpConcrete where + ppr pf + = case pf of + OpConcreteProj arity ix -> text "proj" + <> int arity <> text "_" <> int ix + <> text "#" + + OpConcreteRateOfSeries -> text "rateOfSeries" <> text "#" + OpConcreteNatOfRateNat -> text "natOfRateNat" <> text "#" + + OpConcreteNext 1 -> text "next#" + OpConcreteNext n -> text "next$" <> int n <> text "#" + + OpConcreteDown n -> text "down$" <> int n <> text "#" + OpConcreteTail n -> text "tail$" <> int n <> text "#" + + +-- | Read a series operator name. +readOpConcrete :: String -> Maybe OpConcrete +readOpConcrete str + | Just rest <- stripPrefix "proj" str + , (ds, '_' : rest2) <- span isDigit rest + , not $ null ds + , arity <- read ds + , arity >= 1 + , (ds2, "#") <- span isDigit rest2 + , not $ null ds2 + , ix <- read ds2 + , ix >= 1 + , ix <= arity + = Just $ OpConcreteProj arity ix + + + | Just rest <- stripPrefix "next$" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + , n >= 1 + = Just $ OpConcreteNext n + + | Just rest <- stripPrefix "down$" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + , n >= 1 + = Just $ OpConcreteDown n + + | Just rest <- stripPrefix "tail$" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + , n >= 1 + = Just $ OpConcreteTail n + + | otherwise + = case str of + "rateOfSeries#" -> Just $ OpConcreteRateOfSeries + "natOfRateNat#" -> Just $ OpConcreteNatOfRateNat + "next#" -> Just $ OpConcreteNext 1 + _ -> Nothing + + +-- | Yield the type of a series operator. +typeOpConcrete :: OpConcrete -> Type Name +typeOpConcrete op + = case op of + -- Tuple projections -------------------- + OpConcreteProj a ix + -> tForalls (replicate a kData) + $ \_ -> tFun (tTupleN [TVar (UIx i) | i <- reverse [0..a-1]]) + (TVar (UIx (a - ix))) + + + -- rateOfSeries# :: [k : Rate]. [a : Data] + -- . Series k a -> RateNat k + OpConcreteRateOfSeries + -> tForalls [kRate, kData] $ \[tK, tA] + -> tSeries tK tA `tFun` tRateNat tK + + -- natOfRateNat# :: [k : Rate]. RateNat k -> Nat# + OpConcreteNatOfRateNat + -> tForall kRate $ \tK + -> tRateNat tK `tFun` tNat + + -- next# :: [a : Data]. [k : Rate]. Series# k a -> Nat# -> a + OpConcreteNext 1 + -> tForalls [kData, kRate] + $ \[tA, tK] -> tSeries tK tA `tFun` tNat `tFun` tA + + -- next$N# :: [a : Data]. [k : Rate] + -- . Series# (DownN# k) a -> Nat# -> VecN# a + OpConcreteNext n + -> tForalls [kData, kRate] + $ \[tA, tK] -> tSeries (tDown n tK) tA `tFun` tNat `tFun` tVec n tA + + -- down$N# :: [k : Rate]. [a : Data]. + -- . RateNat (DownN# k) -> Series# k a -> Series# (DownN# k) a + OpConcreteDown n + -> tForalls [kRate, kData] + $ \[tK, tA] -> tRateNat (tDown n tK) + `tFun` tSeries tK tA `tFun` tSeries (tDown n tK) tA + + -- tail$N# :: [k : Rate]. [a : Data]. + -- . RateNat (TailN# k) -> Series# k a -> Series# (TailN# k) a + OpConcreteTail n + -> tForalls [kRate, kData] + $ \[tK, tA] -> tRateNat (tTail n tK) + `tFun` tSeries tK tA `tFun` tSeries (tTail n tK) tA + + +-- Compounds ------------------------------------------------------------------ +type TypeF = Type Name +type ExpF = Exp () Name + +xProj :: [Type Name] -> Int -> Exp () Name -> Exp () Name +xProj ts ix x + = xApps (xVarOpConcrete (OpConcreteProj (length ts) ix)) + ([XType t | t <- ts] ++ [x]) + + +xRateOfSeries :: TypeF -> TypeF -> ExpF -> ExpF +xRateOfSeries tK tA xS + = xApps (xVarOpConcrete OpConcreteRateOfSeries) + [XType tK, XType tA, xS] + + +xNatOfRateNat :: TypeF -> ExpF -> ExpF +xNatOfRateNat tK xR + = xApps (xVarOpConcrete OpConcreteNatOfRateNat) + [XType tK, xR] + + +xNext :: TypeF -> TypeF -> ExpF -> ExpF -> ExpF +xNext tRate tElem xStream xIndex + = xApps (xVarOpConcrete (OpConcreteNext 1)) + [XType tElem, XType tRate, xStream, xIndex] + + +xNextC :: Int -> TypeF -> TypeF -> ExpF -> ExpF -> ExpF +xNextC c tRate tElem xStream xIndex + = xApps (xVarOpConcrete (OpConcreteNext c)) + [XType tElem, XType tRate, xStream, xIndex] + + +xDown :: Int -> TypeF -> TypeF -> ExpF -> ExpF -> ExpF +xDown n tR tE xRN xS + = xApps (xVarOpConcrete (OpConcreteDown n)) + [XType tR, XType tE, xRN, xS] + + +xTail :: Int -> TypeF -> TypeF -> ExpF -> ExpF -> ExpF +xTail n tR tE xRN xS + = xApps (xVarOpConcrete (OpConcreteTail n)) + [XType tR, XType tE, xRN, xS] + + +-- Utils ----------------------------------------------------------------------- +xVarOpConcrete :: OpConcrete -> Exp () Name +xVarOpConcrete op + = XVar (UPrim (NameOpConcrete op) (typeOpConcrete op)) + diff --git a/DDC/Core/Flow/Prim/OpControl.hs b/DDC/Core/Flow/Prim/OpControl.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Prim/OpControl.hs @@ -0,0 +1,132 @@ + +-- | Control constructs used in lowered code. +module DDC.Core.Flow.Prim.OpControl + ( readOpControl + , typeOpControl + , xLoopN + , xGuard + , xSegment + , xSplit) +where +import DDC.Core.Flow.Prim.KiConFlow +import DDC.Core.Flow.Prim.TyConPrim +import DDC.Core.Flow.Prim.TyConFlow +import DDC.Core.Flow.Prim.Base +import DDC.Core.Compounds.Simple +import DDC.Core.Exp.Simple +import DDC.Base.Pretty +import Control.DeepSeq +import Data.Char +import Data.List + + +instance NFData OpControl + + +instance Pretty OpControl where + ppr fo + = case fo of + OpControlLoop -> text "loop#" + OpControlLoopN -> text "loopn#" + OpControlGuard -> text "guard#" + OpControlSegment -> text "segment#" + OpControlSplit n -> text "split$" <> int n <> text "#" + + +-- | Read a control operator name. +readOpControl :: String -> Maybe OpControl +readOpControl str + | Just rest <- stripPrefix "split$" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , arity <- read ds + = Just $ OpControlSplit arity + + | otherwise + = case str of + "loop#" -> Just $ OpControlLoop + "loopn#" -> Just $ OpControlLoopN + "guard#" -> Just $ OpControlGuard + "segment#" -> Just $ OpControlSegment + _ -> Nothing + + +-- Types ---------------------------------------------------------------------- +-- | Yield the type of a control operator. +typeOpControl :: OpControl -> Type Name +typeOpControl op + = case op of + -- loop# :: [k : Rate]. (Nat# -> Unit) -> Unit + OpControlLoop + -> tForall kRate + $ \_ -> (tNat `tFun` tUnit) `tFun` tUnit + + -- loopn# :: [k : Rate]. RateNat# k -> (Nat# -> Unit) -> Unit + OpControlLoopN + -> tForall kRate + $ \kR -> tRateNat kR `tFun` (tNat `tFun` tUnit) `tFun` tUnit + + -- guard# :: Ref# Nat# -> Bool# -> (Nat# -> Unit) -> Unit + OpControlGuard + -> tRef tNat + `tFun` tBool + `tFun` (tNat `tFun` tUnit) + `tFun` tUnit + + -- segment# :: Ref Nat# -> Nat# -> (Nat# -> Nat# -> Unit) -> Unit + -- In the worker the first parameter is the index of the current + -- element in the segment, and the second is the index into the + -- overall series. + OpControlSegment + -> tRef tNat + `tFun` tNat + `tFun` (tNat `tFun` tNat `tFun` tUnit) + `tFun` tUnit + + -- split# :: [k : Rate]. RateNat# k + -- -> (RateNat# (Down8# k) -> Unit) + -- -> (RateNat# (Tail8# k) -> Unit) + -- -> Unit + OpControlSplit n + -> tForall kRate + $ \tK -> tRateNat tK + `tFun` (tRateNat (tDown n tK) `tFun` tUnit) + `tFun` (tRateNat (tTail n tK) `tFun` tUnit) + `tFun` tUnit + + +-- Compounds ------------------------------------------------------------------ +type TypeF = Type Name +type ExpF = Exp () Name + + +xLoopN :: TypeF -> ExpF -> ExpF -> ExpF +xLoopN tR xRN xF + = xApps (xVarOpControl OpControlLoopN) + [XType tR, xRN, xF] + + +xGuard :: ExpF -> ExpF -> ExpF -> ExpF +xGuard xCount xFlag xFun + = xApps (xVarOpControl OpControlGuard) + [xCount, xFlag, xFun] + + +xSegment :: ExpF -> ExpF -> ExpF -> ExpF +xSegment xCount xIters xFun + = xApps (xVarOpControl OpControlSegment) + [xCount, xIters, xFun] + + +xSplit :: Int -> TypeF -> ExpF + -> ExpF -> ExpF -> ExpF +xSplit n tK xRN xDownFn xTailFn + = xApps (xVarOpControl $ OpControlSplit n) + [ XType tK, xRN, xDownFn, xTailFn ] + + +-- Utils ----------------------------------------------------------------------- +xVarOpControl :: OpControl -> ExpF +xVarOpControl op + = XVar (UPrim (NameOpControl op) (typeOpControl op)) + diff --git a/DDC/Core/Flow/Prim/OpFlow.hs b/DDC/Core/Flow/Prim/OpFlow.hs deleted file mode 100644 --- a/DDC/Core/Flow/Prim/OpFlow.hs +++ /dev/null @@ -1,252 +0,0 @@ - -module DDC.Core.Flow.Prim.OpFlow - ( readOpFlow - , typeOpFlow - , xRateOfSeries - , xNatOfRateNat) -where -import DDC.Core.Flow.Prim.KiConFlow -import DDC.Core.Flow.Prim.TyConFlow -import DDC.Core.Flow.Prim.TyConPrim -import DDC.Core.Flow.Prim.Base -import DDC.Core.Transform.LiftT -import DDC.Core.Compounds.Simple -import DDC.Core.Exp.Simple -import DDC.Base.Pretty -import Control.DeepSeq -import Data.List -import Data.Char - - -instance NFData OpFlow - - -instance Pretty OpFlow where - ppr pf - = case pf of - OpFlowVectorOfSeries -> text "vectorOfSeries" <> text "#" - OpFlowRateOfSeries -> text "rateOfSeries" <> text "#" - OpFlowNatOfRateNat -> text "natOfRateNat" <> text "#" - - OpFlowMkSel 1 -> text "mkSel" <> text "#" - OpFlowMkSel n -> text "mkSel" <> int n <> text "#" - - OpFlowMap 1 -> text "map" <> text "#" - OpFlowMap i -> text "map" <> int i <> text "#" - - OpFlowRep -> text "rep" <> text "#" - OpFlowReps -> text "reps" <> text "#" - - OpFlowFold -> text "fold" <> text "#" - OpFlowFoldIndex -> text "foldIndex" <> text "#" - OpFlowFolds -> text "folds" <> text "#" - - OpFlowUnfold -> text "unfold" <> text "#" - OpFlowUnfolds -> text "unfolds" <> text "#" - - OpFlowSplit i -> text "split" <> int i <> text "#" - OpFlowCombine i -> text "combine" <> int i <> text "#" - - OpFlowPack -> text "pack" <> text "#" - - --- | Read a data flow operator name. -readOpFlow :: String -> Maybe OpFlow -readOpFlow str - | Just rest <- stripPrefix "mkSel" str - , (ds, "#") <- span isDigit rest - , not $ null ds - , arity <- read ds - , arity == 1 - = Just $ OpFlowMkSel arity - - | Just rest <- stripPrefix "map" str - , (ds, "#") <- span isDigit rest - , not $ null ds - , arity <- read ds - = Just $ OpFlowMap arity - - | Just rest <- stripPrefix "split" str - , (ds, "#") <- span isDigit rest - , not $ null ds - , arity <- read ds - = Just $ OpFlowSplit arity - - | Just rest <- stripPrefix "combine" str - , (ds, "#") <- span isDigit rest - , not $ null ds - , arity <- read ds - = Just $ OpFlowCombine arity - - | otherwise - = case str of - "vectorOfSeries#" -> Just $ OpFlowVectorOfSeries - "rateOfSeries#" -> Just $ OpFlowRateOfSeries - "natOfRateNat#" -> Just $ OpFlowNatOfRateNat - "mkSel#" -> Just $ OpFlowMkSel 1 - "map#" -> Just $ OpFlowMap 1 - "rep#" -> Just $ OpFlowRep - "reps#" -> Just $ OpFlowReps - "fold#" -> Just $ OpFlowFold - "foldIndex#" -> Just $ OpFlowFoldIndex - "folds#" -> Just $ OpFlowFolds - "unfold#" -> Just $ OpFlowUnfold - "unfolds#" -> Just $ OpFlowUnfolds - "pack#" -> Just $ OpFlowPack - _ -> Nothing - - --- Types ----------------------------------------------------------------------- --- | Yield the type of a data flow operator, --- or `error` if there isn't one. -typeOpFlow :: OpFlow -> Type Name -typeOpFlow op - = case takeTypeOpFlow op of - Just t -> t - Nothing -> error $ "ddc-core-flow.typeOpFlow: invalid op " ++ show op - - --- | Yield the type of a data flow operator. -takeTypeOpFlow :: OpFlow -> Maybe (Type Name) -takeTypeOpFlow op - = case op of - -- Series Conversions ------------------- - -- vectorOfSeries# :: [k : Rate]. [a : Data] - -- . Series k a -> Vector a - OpFlowVectorOfSeries - -> Just $ tForalls [kRate, kData] $ \[tK, tA] - -> tSeries tK tA `tFun` tVector tA - - -- rateOfSeries# :: [k : Rate]. [a : Data] - -- . Series k a -> RateNat k - OpFlowRateOfSeries - -> Just $ tForalls [kRate, kData] $ \[tK, tA] - -> tSeries tK tA `tFun` tRateNat tK - - -- natOfRateNat# :: [k : Rate]. RateNat k -> Nat# - OpFlowNatOfRateNat - -> Just $ tForall kRate $ \tK - -> tRateNat tK `tFun` tNat - - - -- Selectors ---------------------------- - -- mkSel1# :: [k1 : Rate]. [a : Data] - -- . Series k1 Bool# - -- -> ([k2 : Rate]. Sel1 k1 k2 -> a) - -- -> a - OpFlowMkSel 1 - -> Just $ tForalls [kRate, kData] $ \[tK1, tA] - -> tSeries tK1 tBool - `tFun` (tForall kRate $ \tK2 - -> tSel1 (liftT 1 tK1) tK2 `tFun` (liftT 1 tA)) - `tFun` tA - - - -- Maps --------------------------------- - -- map :: [k : Rate] [a b : Data] - -- . (a -> b) -> Series k a -> Series k b - OpFlowMap 1 - -> Just $ tForalls [kRate, kData, kData] $ \[tK, tA, tB] - -> (tA `tFun` tB) - `tFun` tSeries tK tA - `tFun` tSeries tK tB - - -- mapN :: [k : Rate] [a0..aN : Data] - -- . (a0 -> .. aN) -> Series k a0 -> .. Series k aN - OpFlowMap n - | n >= 2 - , Just tWork <- tFunOfList - [ TVar (UIx i) - | i <- reverse [0..n] ] - - , Just tBody <- tFunOfList - (tWork : [tSeries (TVar (UIx (n + 1))) (TVar (UIx i)) - | i <- reverse [0..n] ]) - - -> Just $ foldr TForall tBody - [ BAnon k | k <- kRate : replicate (n + 1) kData ] - - - -- Replicates ------------------------- - -- rep :: [a : Data] [k : Rate] - -- . a -> Series k a - OpFlowRep - -> Just $ tForalls [kData, kRate] $ \[tA, tR] - -> tA `tFun` tSeries tR tA - - -- reps :: [k1 k2 : Rate]. [a : Data] - -- . Segd k1 k2 - -- -> Series k1 a - -- -> Series k2 a - OpFlowReps - -> Just $ tForalls [kRate, kRate, kData] $ \[tK1, tK2, tA] - -> tSegd tK1 tK2 - `tFun` tSeries tK1 tA - `tFun` tSeries tK2 tA - - - -- Folds -------------------------------- - -- fold :: [k : Rate]. [a b: Data] - -- . (a -> b -> a) -> a -> Series k b -> a - OpFlowFold - -> Just $ tForalls [kRate, kData, kData] $ \[tK, tA, tB] - -> (tA `tFun` tB `tFun` tA) - `tFun` tA - `tFun` tSeries tK tB - `tFun` tA - - -- foldIndex :: [k : Rate]. [a b: Data] - -- . (Int# -> a -> b -> a) -> a -> Series k b -> a - OpFlowFoldIndex - -> Just $ tForalls [kRate, kData, kData] $ \[tK, tA, tB] - -> (tInt `tFun` tA `tFun` tB `tFun` tA) - `tFun` tA - `tFun` tSeries tK tB - `tFun` tA - - -- folds :: [k1 k2 : Rate]. [a b: Data] - -- . Segd k1 k2 - -- -> (a -> b -> a) -- fold operator - -- -> Series k1 a -- start values - -- -> Series k2 b -- source elements - -- -> Series k1 a -- result values - OpFlowFolds - -> Just $ tForalls [kRate, kRate, kData, kData] $ \[tK1, tK2, tA, tB] - -> tSegd tK1 tK2 - `tFun` (tInt `tFun` tA `tFun` tB `tFun` tA) - `tFun` tSeries tK1 tA - `tFun` tSeries tK2 tB - `tFun` tSeries tK1 tA - - - -- Packs -------------------------------- - -- pack :: [k1 k2 : Rate]. [a : Data] - -- . Sel2 k1 k2 - -- -> Series k1 a -> Series k2 a - OpFlowPack - -> Just $ tForalls [kRate, kRate, kData] $ \[tK1, tK2, tA] - -> tSel1 tK1 tK2 - `tFun` tSeries tK1 tA - `tFun` tSeries tK2 tA - - _ -> Nothing - - --- Compounds ------------------------------------------------------------------ -xRateOfSeries :: Type Name -> Type Name -> Exp () Name -> Exp () Name -xRateOfSeries tK tA xS - = xApps (xVarOpFlow OpFlowRateOfSeries) - [XType tK, XType tA, xS] - - -xNatOfRateNat :: Type Name -> Exp () Name -> Exp () Name -xNatOfRateNat tK xR - = xApps (xVarOpFlow OpFlowNatOfRateNat) - [XType tK, xR] - - --- Utils ----------------------------------------------------------------------- -xVarOpFlow :: OpFlow -> Exp () Name -xVarOpFlow op - = XVar (UPrim (NameOpFlow op) (typeOpFlow op)) - diff --git a/DDC/Core/Flow/Prim/OpLoop.hs b/DDC/Core/Flow/Prim/OpLoop.hs deleted file mode 100644 --- a/DDC/Core/Flow/Prim/OpLoop.hs +++ /dev/null @@ -1,84 +0,0 @@ - --- | Loop related names. -module DDC.Core.Flow.Prim.OpLoop - ( readOpLoop - , typeOpLoop - , xLoopLoopN - , xLoopGuard) -where -import DDC.Core.Flow.Prim.KiConFlow -import DDC.Core.Flow.Prim.TyConPrim -import DDC.Core.Flow.Prim.TyConFlow -import DDC.Core.Flow.Prim.Base -import DDC.Core.Compounds.Simple -import DDC.Core.Exp.Simple -import DDC.Base.Pretty -import Control.DeepSeq - - -instance NFData OpLoop - - -instance Pretty OpLoop where - ppr fo - = case fo of - OpLoopLoop -> text "loop#" - OpLoopLoopN -> text "loopn#" - - OpLoopGuard -> text "guard#" - - --- | Read a loop operator name. -readOpLoop :: String -> Maybe OpLoop -readOpLoop str - = case str of - "loop#" -> Just $ OpLoopLoop - "loopn#" -> Just $ OpLoopLoopN - "guard#" -> Just $ OpLoopGuard - _ -> Nothing - - --- Types ---------------------------------------------------------------------- --- | Yield the type of a loop operator. -typeOpLoop :: OpLoop -> Type Name -typeOpLoop op - = case op of - -- loop# :: [k : Rate]. (Nat# -> Unit) -> Unit - OpLoopLoop - -> tForall kRate - $ \_ -> (tNat `tFun` tUnit) `tFun` tUnit - - -- loopn# :: [k : Rate]. RateNat k -> (Nat# -> Unit) -> Unit - OpLoopLoopN - -> tForall kRate - $ \kR -> tRateNat kR `tFun` (tNat `tFun` tUnit) `tFun` tUnit - - -- guard# :: Ref# Nat# -> Bool# - -- -> (Nat# -> Unit) -> Unit - OpLoopGuard - -> tRef tNat - `tFun` tBool - `tFun` (tNat `tFun` tUnit) - `tFun` tUnit - - --- Compounds ------------------------------------------------------------------ -xLoopLoopN :: Type Name -> Exp () Name -> Exp () Name -> Exp () Name -xLoopLoopN tR xRN xF - = xApps (xVarOpLoop OpLoopLoopN) [XType tR, xRN, xF] - - -xLoopGuard - :: Exp () Name -- ^ Reference to guard counter. - -> Exp () Name -- ^ Boolean flag to test. - -> Exp () Name -- ^ Body of guard. - -> Exp () Name - -xLoopGuard xB xCount xF - = xApps (xVarOpLoop OpLoopGuard) [xCount, xB, xF] - - --- Utils ----------------------------------------------------------------------- -xVarOpLoop :: OpLoop -> Exp () Name -xVarOpLoop op - = XVar (UPrim (NameOpLoop op) (typeOpLoop op)) diff --git a/DDC/Core/Flow/Prim/OpPrim.hs b/DDC/Core/Flow/Prim/OpPrim.hs --- a/DDC/Core/Flow/Prim/OpPrim.hs +++ b/DDC/Core/Flow/Prim/OpPrim.hs @@ -1,9 +1,17 @@ module DDC.Core.Flow.Prim.OpPrim ( typePrimCast - , typePrimArith) + , typePrimArith + , typePrimVec + + -- * Compounds + , xvRep + , xvProj + , xvGather + , xvScatter) where import DDC.Core.Flow.Prim.TyConPrim +import DDC.Core.Flow.Prim.TyConFlow import DDC.Core.Flow.Prim.Base import DDC.Core.Compounds.Simple import DDC.Core.Exp.Simple @@ -13,6 +21,9 @@ typePrimCast :: PrimCast -> Type Name typePrimCast cc = case cc of + PrimCastConvert + -> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFun` t1 + PrimCastPromote -> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFun` t1 @@ -51,3 +62,64 @@ PrimArithBAnd -> tForall kData $ \t -> t `tFun` t `tFun` t PrimArithBOr -> tForall kData $ \t -> t `tFun` t `tFun` t PrimArithBXOr -> tForall kData $ \t -> t `tFun` t `tFun` t + + +-- | Take the type of a primitive vector operator. +typePrimVec :: PrimVec -> Type Name +typePrimVec op + = case op of + PrimVecNeg n -> tForall kData $ \t -> tVec n t `tFun` tVec n t + PrimVecAdd n -> tForall kData $ \t -> tVec n t `tFun` tVec n t `tFun` tVec n t + PrimVecSub n -> tForall kData $ \t -> tVec n t `tFun` tVec n t `tFun` tVec n t + PrimVecMul n -> tForall kData $ \t -> tVec n t `tFun` tVec n t `tFun` tVec n t + PrimVecDiv n -> tForall kData $ \t -> tVec n t `tFun` tVec n t `tFun` tVec n t + + PrimVecRep n + -> tForall kData $ \t -> t `tFun` tVec n t + + PrimVecPack n + -> tForall kData + $ \t -> let Just t' = tFunOfList (replicate n t ++ [tVec n t]) + in t' + + PrimVecProj n _ + -> tForall kData + $ \t -> tVec n t `tFun` t + + PrimVecGather n + -> tForall kData + $ \t -> tVector t `tFun` tVec n tNat `tFun` tVec n t + + PrimVecScatter n + -> tForall kData + $ \t -> tVector t `tFun` tVec n tNat `tFun` tVec n t `tFun` tUnit + + +-- Compounds ------------------------------------------------------------------ +xvRep :: Int -> Type Name -> Exp () Name -> Exp () Name +xvRep c tA xZ + = xApps (xVarPrimVec (PrimVecRep c)) + [XType tA, xZ] + +xvProj :: Int -> Int -> Type Name -> Exp () Name -> Exp () Name +xvProj n i tA xV + = xApps (xVarPrimVec (PrimVecProj n i)) + [XType tA, xV] + +xvGather :: Int -> Type Name -> Exp () Name -> Exp () Name -> Exp () Name +xvGather c tA xVec xIxs + = xApps (xVarPrimVec (PrimVecGather c)) + [XType tA, xVec, xIxs] + + +xvScatter :: Int -> Type Name -> Exp () Name -> Exp () Name -> Exp () Name -> Exp () Name +xvScatter c tA xVec xIxs xElems + = xApps (xVarPrimVec (PrimVecScatter c)) + [XType tA, xVec, xIxs, xElems] + + +-- Utils ----------------------------------------------------------------------- +xVarPrimVec :: PrimVec -> Exp () Name +xVarPrimVec op + = XVar (UPrim (NamePrimVec op) (typePrimVec op)) + diff --git a/DDC/Core/Flow/Prim/OpSeries.hs b/DDC/Core/Flow/Prim/OpSeries.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Prim/OpSeries.hs @@ -0,0 +1,261 @@ + +module DDC.Core.Flow.Prim.OpSeries + ( readOpSeries + , typeOpSeries) +where +import DDC.Core.Flow.Prim.KiConFlow +import DDC.Core.Flow.Prim.TyConFlow +import DDC.Core.Flow.Prim.TyConPrim +import DDC.Core.Flow.Prim.Base +import DDC.Core.Transform.LiftT +import DDC.Core.Compounds.Simple +import DDC.Core.Exp.Simple +import DDC.Base.Pretty +import Control.DeepSeq +import Data.List +import Data.Char + + +instance NFData OpSeries + + +instance Pretty OpSeries where + ppr pf + = case pf of + OpSeriesRep -> text "srep" <> text "#" + OpSeriesReps -> text "sreps" <> text "#" + + OpSeriesIndices -> text "sindices" <> text "#" + + OpSeriesFill -> text "sfill" <> text "#" + + OpSeriesGather -> text "sgather" <> text "#" + OpSeriesScatter -> text "sscatter" <> text "#" + + OpSeriesMkSel 1 -> text "smkSel" <> text "#" + OpSeriesMkSel n -> text "smkSel" <> int n <> text "#" + + OpSeriesMkSegd -> text "smkSegd" <> text "#" + + OpSeriesMap 1 -> text "smap" <> text "#" + OpSeriesMap i -> text "smap" <> int i <> text "#" + + OpSeriesPack -> text "spack" <> text "#" + + OpSeriesReduce -> text "sreduce" <> text "#" + OpSeriesFolds -> text "sfolds" <> text "#" + + OpSeriesJoin -> text "pjoin" <> text "#" + + OpSeriesRunProcess 1 -> text "runProcess" <> text "#" + OpSeriesRunProcess n -> text "runProcess" <> int n <> text "#" + + +-- | Read a data flow operator name. +readOpSeries :: String -> Maybe OpSeries +readOpSeries str + | Just rest <- stripPrefix "smap" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , arity <- read ds + = Just $ OpSeriesMap arity + + | Just rest <- stripPrefix "smkSel" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , arity <- read ds + , arity == 1 + = Just $ OpSeriesMkSel arity + + | Just rest <- stripPrefix "runProcess" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , arity <- read ds + = Just $ OpSeriesRunProcess arity + + + | otherwise + = case str of + "srep#" -> Just $ OpSeriesRep + "sreps#" -> Just $ OpSeriesReps + "sindices#" -> Just $ OpSeriesIndices + "sgather#" -> Just $ OpSeriesGather + "smkSel#" -> Just $ OpSeriesMkSel 1 + "smkSegd#" -> Just $ OpSeriesMkSegd + "smap#" -> Just $ OpSeriesMap 1 + "spack#" -> Just $ OpSeriesPack + "sreduce#" -> Just $ OpSeriesReduce + "sfolds#" -> Just $ OpSeriesFolds + "sfill#" -> Just $ OpSeriesFill + "sscatter#" -> Just $ OpSeriesScatter + "pjoin#" -> Just $ OpSeriesJoin + "runProcess#" -> Just $ OpSeriesRunProcess 1 + _ -> Nothing + + +-- Types ----------------------------------------------------------------------- +-- | Yield the type of a data flow operator, +-- or `error` if there isn't one. +typeOpSeries :: OpSeries -> Type Name +typeOpSeries op + = case takeTypeOpSeries op of + Just t -> t + Nothing -> error $ "ddc-core-flow.typeOpSeries: invalid op " ++ show op + + +-- | Yield the type of a data flow operator. +takeTypeOpSeries :: OpSeries -> Maybe (Type Name) +takeTypeOpSeries op + = case op of + -- Replicates ------------------------- + -- rep :: [k : Rate] [a : Data] + -- . a -> Series k a + OpSeriesRep + -> Just $ tForalls [kRate, kData] $ \[tR, tA] + -> tA `tFun` tSeries tR tA + + -- reps :: [k1 k2 : Rate]. [a : Data] + -- . Segd k1 k2 -> Series k1 a -> Series k2 a + OpSeriesReps + -> Just $ tForalls [kRate, kRate, kData] $ \[tK1, tK2, tA] + -> tSegd tK1 tK2 `tFun` tSeries tK1 tA `tFun` tSeries tK2 tA + + + -- Indices ------------------------------ + -- indices :: [k1 k2 : Rate]. + -- . Segd k1 k2 -> Series k2 Nat + OpSeriesIndices + -> Just $ tForalls [kRate, kRate] $ \[tK1, tK2] + -> tSegd tK1 tK2 `tFun` tSeries tK2 tNat + + + -- Maps --------------------------------- + -- map :: [k : Rate] [a b : Data] + -- . (a -> b) -> Series k a -> Series k b + OpSeriesMap 1 + -> Just $ tForalls [kRate, kData, kData] $ \[tK, tA, tB] + -> (tA `tFun` tB) + `tFun` tSeries tK tA + `tFun` tSeries tK tB + + -- mapN :: [k : Rate] [a0..aN : Data] + -- . (a0 -> .. aN) -> Series k a0 -> .. Series k aN + OpSeriesMap n + | n >= 2 + , Just tWork <- tFunOfList + [ TVar (UIx i) + | i <- reverse [0..n] ] + + , Just tBody <- tFunOfList + (tWork : [tSeries (TVar (UIx (n + 1))) (TVar (UIx i)) + | i <- reverse [0..n] ]) + + -> Just $ foldr TForall tBody + [ BAnon k | k <- kRate : replicate (n + 1) kData ] + + + -- Packs -------------------------------- + -- pack :: [k1 k2 : Rate]. [a : Data] + -- . Sel2 k1 k2 + -- -> Series k1 a -> Series k2 a + OpSeriesPack + -> Just $ tForalls [kRate, kRate, kData] $ \[tK1, tK2, tA] + -> tSel1 tK1 tK2 + `tFun` tSeries tK1 tA `tFun` tSeries tK2 tA + + + -- Processes ---------------------------- + -- join# :: Process -> Process -> Process + OpSeriesJoin + -> Just $ tProcess `tFun` tProcess `tFun` tProcess + + + -- mkSel1# :: [k1 : Rate]. + -- . Series k1 Bool# + -- -> ([k2 : Rate]. Sel1 k1 k2 -> Process#) + -- -> Process# + OpSeriesMkSel 1 + -> Just $ tForalls [kRate] $ \[tK1] + -> tSeries tK1 tBool + `tFun` (tForall kRate $ \tK2 + -> tSel1 (liftT 1 tK1) tK2 `tFun` tProcess) + `tFun` tProcess + + + -- mkSegd# :: [k1 : Rate] + -- . Series# k1 Nat# + -- -> ([k2 : Rate]. Segd# k1 k2 -> Process#) + -- -> Process# + OpSeriesMkSegd + -> Just $ tForalls [kRate] $ \[tK1] + -> tSeries tK1 tNat + `tFun` (tForall kRate $ \tK2 + -> tSegd (liftT 1 tK1) tK2 `tFun` tProcess) + `tFun` tProcess + + + -- runProcessN# :: [a0..aN : Data] + -- . Vector a0 .. Vector aN + -- -> ([k : Rate]. RateNat k -> Series k a0 .. Series k aN -> Process) + -- -> Bool + OpSeriesRunProcess n + | tK <- TVar (UIx 0) + + , Just tWork <- tFunOfList + $ [ tRateNat tK ] + ++[ tSeries tK (TVar (UIx i)) + | i <- reverse [1..n] ] + ++[ tProcess ] + + , tWork' <- TForall (BAnon kRate) tWork + + , Just tBody <- tFunOfList + $ [ tVector (TVar (UIx i)) | i <- reverse [0..n-1] ] + ++[ tWork', tBool ] + + -> Just $ foldr TForall tBody + [ BAnon k | k <- replicate n kData ] + + + -- Reductions ------------------------------- + -- reduce# :: [k : Rate]. [a : Data] + -- . Ref a -> (a -> a -> a) -> a -> Series k a -> Process + OpSeriesReduce + -> Just $ tForalls [kRate, kData] $ \[tK, tA] + -> tRef tA + `tFun` (tA `tFun` tA `tFun` tA) + `tFun` tA + `tFun` tSeries tK tA + `tFun` tProcess + + + -- folds# :: [k1 k2 : Rate]. [a : Data] + -- . Segd# k1 k2 -> Series k1 a -> Series k2 b + OpSeriesFolds + -> Just $ tForalls [kRate, kRate, kData] $ \[tK1, tK2, tA] + -> tSegd tK1 tK2 `tFun` tSeries tK1 tA `tFun` tSeries tK2 tA + + + -- Store operators --------------------------- + -- scatter# :: [k : Rate]. [a : Data] + -- . Vector a -> Series k Nat# -> Series k a -> Process + OpSeriesScatter + -> Just $ tForalls [kRate, kData] $ \[tK, tA] + -> tVector tA + `tFun` tSeries tK tNat `tFun` tSeries tK tA `tFun` tProcess + + + -- gather# :: [k : Rate]. [a : Data] + -- . Vector a -> Series k Nat# -> Series k a + OpSeriesGather + -> Just $ tForalls [kRate, kData] $ \[tK, tA] + -> tVector tA + `tFun` tSeries tK tNat `tFun` tSeries tK tA + + + -- fill# :: [k : Rate]. [a : Data]. Vector a -> Series k a -> Process + OpSeriesFill + -> Just $ tForalls [kRate, kData] $ \[tK, tA] + -> tVector tA `tFun` tSeries tK tA `tFun` tProcess + + _ -> Nothing diff --git a/DDC/Core/Flow/Prim/OpStore.hs b/DDC/Core/Flow/Prim/OpStore.hs --- a/DDC/Core/Flow/Prim/OpStore.hs +++ b/DDC/Core/Flow/Prim/OpStore.hs @@ -3,10 +3,12 @@ ( OpStore (..) , readOpStore , typeOpStore - , xNew, xRead, xWrite - , xNewVector, xReadVector, xWriteVector, xNewVectorR, xNewVectorN - , xSliceVector - , xNext) + , xNew, xRead, xWrite + , xNewVector, xNewVectorR, xNewVectorN + , xReadVector, xReadVectorC + , xWriteVector, xWriteVectorC + , xTailVector + , xTruncVector) where import DDC.Core.Flow.Prim.KiConFlow import DDC.Core.Flow.Prim.TyConFlow @@ -16,7 +18,8 @@ import DDC.Core.Exp.Simple import DDC.Base.Pretty import Control.DeepSeq - +import Data.List +import Data.Char instance NFData OpStore @@ -30,43 +33,70 @@ OpStoreWrite -> text "write#" -- Vectors. - OpStoreNewVector -> text "newVector#" - OpStoreNewVectorR -> text "newVectorR#" - OpStoreNewVectorN -> text "newVectorN#" - OpStoreReadVector -> text "readVector#" - OpStoreWriteVector -> text "writeVector#" - OpStoreSliceVector -> text "sliceVector#" + OpStoreNewVector -> text "vnew#" + OpStoreNewVectorR -> text "vnewR#" + OpStoreNewVectorN -> text "vnewN#" - -- Streams. - OpStoreNext -> text "next#" + OpStoreReadVector 1 -> text "vread#" + OpStoreReadVector n -> text "vread$" <> int n <> text "#" + OpStoreWriteVector 1 -> text "vwrite#" + OpStoreWriteVector n -> text "vwrite$" <> int n <> text "#" + OpStoreTailVector 1 -> text "vtail#" + OpStoreTailVector n -> text "vtail" <> int n <> text "#" + + OpStoreTruncVector -> text "vtrunc#" + + -- | Read a store operator name. readOpStore :: String -> Maybe OpStore readOpStore str - = case str of - "new#" -> Just OpStoreNew - "read#" -> Just OpStoreRead - "write#" -> Just OpStoreWrite + | Just rest <- stripPrefix "vread$" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + , n >= 1 + = Just $ OpStoreReadVector n - "newVector#" -> Just OpStoreNewVector - "newVectorR#" -> Just OpStoreNewVectorR - "newVectorN#" -> Just OpStoreNewVectorN - "readVector#" -> Just OpStoreReadVector - "writeVector#" -> Just OpStoreWriteVector - "sliceVector#" -> Just OpStoreSliceVector + | Just rest <- stripPrefix "vwrite$" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + , n >= 1 + = Just $ OpStoreWriteVector n - "next#" -> Just OpStoreNext - _ -> Nothing + | Just rest <- stripPrefix "vtail$" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + , n >= 1 + = Just $ OpStoreTailVector n + | otherwise + = case str of + "new#" -> Just OpStoreNew + "read#" -> Just OpStoreRead + "write#" -> Just OpStoreWrite + + "vnew#" -> Just OpStoreNewVector + "vnewR#" -> Just OpStoreNewVectorR + "vnewN#" -> Just OpStoreNewVectorN + "vread#" -> Just (OpStoreReadVector 1) + "vwrite#" -> Just (OpStoreWriteVector 1) + "vtail#" -> Just (OpStoreTailVector 1) + "vtrunc#" -> Just OpStoreTruncVector + _ -> Nothing + + -- Types ---------------------------------------------------------------------- -- | Yield the type of a store operator. typeOpStore :: OpStore -> Type Name typeOpStore op = case op of -- Assignables ---------------- - -- new# :: [a : Data]. a -> Array# a + -- new# :: [a : Data]. a -> Ref# a OpStoreNew -> tForall kData $ \tA -> tA `tFun` tRef tA @@ -79,41 +109,49 @@ -> tForall kData $ \tA -> tRef tA `tFun` tA `tFun` tUnit -- Arrays --------------------- - -- newVector# :: [a : Data]. Nat -> Vector# a + -- vnew# :: [a : Data]. Nat -> Vector# a OpStoreNewVector -> tForall kData $ \tA -> tNat `tFun` tVector tA - -- newVectorR# :: [a : Data]. [k : Rate]. Vector# a + -- vnew# :: [a : Data]. [k : Rate]. Vector# a OpStoreNewVectorR -> tForalls [kData, kRate] $ \[tA, _] -> tVector tA - -- newVectorN# :: [a : Data]. [k : Rate]. RateNat k -> Vector a + -- vnew# :: [a : Data]. [k : Rate]. RateNat k -> Vector a OpStoreNewVectorN -> tForalls [kData, kRate] $ \[tA, tK] -> tRateNat tK `tFun` tVector tA - -- readVector# :: [a : Data]. Vector# a -> Nat# -> a - OpStoreReadVector + -- vread# :: [a : Data]. Vector# a -> Nat# -> a + OpStoreReadVector 1 -> tForall kData $ \tA -> tVector tA `tFun` tNat `tFun` tA - -- writeVector# :: [a : Data]. Vector# a -> Nat# -> a -> Unit - OpStoreWriteVector + -- vreadN# :: [a : Data]. Vector# a -> Nat# -> VecN# a + OpStoreReadVector n -> tForall kData + $ \tA -> tVector tA `tFun` tNat `tFun` tVec n tA + + -- vwrite# :: [a : Data]. Vector# a -> Nat# -> a -> Unit + OpStoreWriteVector 1 + -> tForall kData $ \tA -> tVector tA `tFun` tNat `tFun` tA `tFun` tUnit - -- sliceVector# :: [a : Data]. Nat# -> Vector# a -> Vector# a - OpStoreSliceVector + -- vwriteN# :: [a : Data]. Vector# a -> Nat# -> VecN# a -> Unit + OpStoreWriteVector n -> tForall kData - $ \tA -> tNat `tFun` tVector tA `tFun` tVector tA + $ \tA -> tVector tA `tFun` tNat `tFun` tVec n tA `tFun` tUnit + -- vtail$N# :: [k : Rate]. [a : Data]. RateNat (TailN k) -> Vector# a -> Vector# a + OpStoreTailVector n + -> tForalls [kRate, kData] + $ \[tK, tA] -> tRateNat (tTail n tK) `tFun` tVector tA `tFun` tVector tA - -- Streams -------------------- - -- next# :: [a : Data]. [k : Rate]. Series# k a -> Nat# -> a - OpStoreNext - -> tForalls [kData, kRate] - $ \[tA, tK] -> tSeries tK tA `tFun` tNat `tFun` tA + -- vtrunc# :: [a : Data]. Nat# -> Vector# a -> Unit + OpStoreTruncVector + -> tForall kData + $ \tA -> tNat `tFun` tVector tA `tFun` tUnit -- Compounds ------------------------------------------------------------------ @@ -155,25 +193,38 @@ xReadVector :: Type Name -> Exp () Name -> Exp () Name -> Exp () Name xReadVector t xArr xIx - = xApps (xVarOpStore OpStoreReadVector) + = xApps (xVarOpStore (OpStoreReadVector 1)) [XType t, xArr, xIx] +xReadVectorC :: Int -> Type Name -> Exp () Name -> Exp () Name -> Exp () Name +xReadVectorC c t xArr xIx + = xApps (xVarOpStore (OpStoreReadVector c)) + [XType t, xArr, xIx] + + xWriteVector :: Type Name -> Exp () Name -> Exp () Name -> Exp () Name -> Exp () Name xWriteVector t xArr xIx xElem - = xApps (xVarOpStore OpStoreWriteVector) + = xApps (xVarOpStore (OpStoreWriteVector 1)) [XType t, xArr, xIx, xElem] -xSliceVector :: Type Name -> Exp () Name -> Exp () Name -> Exp () Name -xSliceVector tElem xLen xArr - = xApps (xVarOpStore OpStoreSliceVector) - [XType tElem, xLen, xArr] +xWriteVectorC :: Int -> Type Name -> Exp () Name -> Exp () Name -> Exp () Name -> Exp () Name +xWriteVectorC c t xArr xIx xElem + = xApps (xVarOpStore (OpStoreWriteVector c)) + [XType t, xArr, xIx, xElem] -xNext :: Type Name -> Type Name -> Exp () Name -> Exp () Name -> Exp () Name -xNext tRate tElem xStream xIndex - = xApps (xVarOpStore OpStoreNext) - [XType tElem, XType tRate, xStream, xIndex] + +xTailVector :: Int -> Type Name -> Type Name -> Exp () Name -> Exp () Name -> Exp () Name +xTailVector n tK tA xRN xVec + = xApps (xVarOpStore (OpStoreTailVector n)) + [XType tK, XType tA, xRN, xVec] + + +xTruncVector :: Type Name -> Exp () Name -> Exp () Name -> Exp () Name +xTruncVector tElem xLen xArr + = xApps (xVarOpStore OpStoreTruncVector) + [XType tElem, xLen, xArr] -- Utils ---------------------------------------------------------------------- diff --git a/DDC/Core/Flow/Prim/OpVector.hs b/DDC/Core/Flow/Prim/OpVector.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Prim/OpVector.hs @@ -0,0 +1,125 @@ +module DDC.Core.Flow.Prim.OpVector + ( readOpVector + , typeOpVector + ) +where +import DDC.Core.Flow.Prim.TyConFlow +import DDC.Core.Flow.Prim.TyConPrim +import DDC.Core.Flow.Prim.Base +import DDC.Core.Compounds.Simple +import DDC.Core.Exp.Simple +import DDC.Base.Pretty +import Control.DeepSeq +import Data.List +import Data.Char + + +instance NFData OpVector + + +instance Pretty OpVector where + ppr pf + = case pf of + OpVectorMap 1 -> text "vmap" <> text "#" + OpVectorMap i -> text "vmap" <> int i <> text "#" + + OpVectorFilter -> text "vfilter" <> text "#" + + OpVectorReduce -> text "vreduce" <> text "#" + + OpVectorGenerate -> text "vgenerate" <> text "#" + OpVectorLength -> text "vlength" <> text "#" + + +-- | Read a data flow operator name. +readOpVector :: String -> Maybe OpVector +readOpVector str + | Just rest <- stripPrefix "vmap" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , arity <- read ds + = Just $ OpVectorMap arity + + | otherwise + = case str of + "vmap#" -> Just $ OpVectorMap 1 + "vfilter#" -> Just $ OpVectorFilter + "vreduce#" -> Just $ OpVectorReduce + "vgenerate#" -> Just $ OpVectorGenerate + "vlength#" -> Just $ OpVectorLength + _ -> Nothing + + +-- Types ----------------------------------------------------------------------- +-- | Yield the type of a data flow operator, +-- or `error` if there isn't one. +typeOpVector :: OpVector -> Type Name +typeOpVector op + = case takeTypeOpVector op of + Just t -> t + Nothing -> error $ "ddc-core-flow.typeOpVector: invalid op " ++ show op + + +-- | Yield the type of a data flow operator. +takeTypeOpVector :: OpVector -> Maybe (Type Name) +takeTypeOpVector op + = case op of + -- Maps --------------------------------- + -- map :: [a b : Data] + -- . (a -> b) -> Vector a -> Vector b + OpVectorMap 1 + -> Just $ tForalls [kData, kData] $ \[tA, tB] + -> (tA `tFun` tB) + `tFun` tVector tA + `tFun` tVector tB + + -- mapN :: [a0..aN : Data] + -- . (a0 -> .. aN) -> Vector a0 -> .. Vector aN + OpVectorMap n + | n >= 2 + , Just tWork <- tFunOfList + [ TVar (UIx i) + | i <- reverse [0..n] ] + + , Just tBody <- tFunOfList + (tWork : [tVector (TVar (UIx i)) + | i <- reverse [0..n] ]) + + -> Just $ foldr TForall tBody + [ BAnon k | k <- replicate (n + 1) kData ] + + -- Selectors ---------------------------- + -- filter# :: [a : Data] + -- . Vector a + -- -> (a -> Bool#) + -- -> Vector a + OpVectorFilter + -> Just $ tForalls [kData] $ \[tA] + -> (tA `tFun` tBool) + `tFun` tVector tA + `tFun` tVector tA + + -- reduce# :: [a: Data] + -- . (a -> a -> a) -> a -> Vector a -> a + OpVectorReduce + -> Just $ tForalls [kData] $ \[tA] + -> (tA `tFun` tA `tFun` tA) + `tFun` tA + `tFun` tVector tA + `tFun` tA + + -- Vector creation and filling ---------- + -- generate :: [a : Data]. Nat# -> (Nat# -> a) -> Vector a + OpVectorGenerate + -> Just $ tForalls [kData] $ \[tA] + -> tNat + `tFun` (tNat `tFun` tA) + `tFun` tVector tA + + -- length :: [a : Data]. Vector a -> Nat# + OpVectorLength + -> Just $ tForalls [kData] $ \[tA] + -> tVector tA `tFun` tNat + + _ -> Nothing + diff --git a/DDC/Core/Flow/Prim/TyConFlow.hs b/DDC/Core/Flow/Prim/TyConFlow.hs --- a/DDC/Core/Flow/Prim/TyConFlow.hs +++ b/DDC/Core/Flow/Prim/TyConFlow.hs @@ -3,6 +3,14 @@ ( TyConFlow (..) , readTyConFlow , kindTyConFlow + + -- * Predicates + , isRateNatType + , isSeriesType + , isRefType + , isVectorType + + -- * Compounds , tTuple1 , tTuple2 , tTupleN @@ -13,7 +21,10 @@ , tSel2 , tRef , tWorld - , tRateNat) + , tRateNat + , tDown + , tTail + , tProcess) where import DDC.Core.Flow.Prim.KiConFlow import DDC.Core.Flow.Prim.Base @@ -39,6 +50,9 @@ TyConFlowRef -> text "Ref#" TyConFlowWorld -> text "World#" TyConFlowRateNat -> text "RateNat#" + TyConFlowDown n -> text "Down" <> int n <> text "#" + TyConFlowTail n -> text "Tail" <> int n <> text "#" + TyConFlowProcess -> text "Process#" -- | Read a type constructor name. @@ -50,6 +64,18 @@ , arity <- read ds = Just $ TyConFlowTuple arity + | Just rest <- stripPrefix "Down" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + = Just $ TyConFlowDown n + + | Just rest <- stripPrefix "Tail" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + = Just $ TyConFlowTail n + | otherwise = case str of "Vector#" -> Just $ TyConFlowVector @@ -59,6 +85,7 @@ "Ref#" -> Just $ TyConFlowRef "World#" -> Just $ TyConFlowWorld "RateNat#" -> Just $ TyConFlowRateNat + "Process#" -> Just $ TyConFlowProcess _ -> Nothing @@ -75,8 +102,44 @@ TyConFlowRef -> kData `kFun` kData TyConFlowWorld -> kData TyConFlowRateNat -> kRate `kFun` kData + TyConFlowDown{} -> kRate `kFun` kRate + TyConFlowTail{} -> kRate `kFun` kRate + TyConFlowProcess -> kData +-- Predicates ----------------------------------------------------------------- +-- | Check if some type is a fully applied type of a RateNat +isRateNatType :: Type Name -> Bool +isRateNatType tt + = case takePrimTyConApps tt of + Just (NameTyConFlow TyConFlowRateNat, [_]) -> True + _ -> False + + +-- | Check if some type is a fully applied type of a Series. +isSeriesType :: Type Name -> Bool +isSeriesType tt + = case takePrimTyConApps tt of + Just (NameTyConFlow TyConFlowSeries, [_, _]) -> True + _ -> False + + +-- | Check is some type is a fully applied type of a Ref. +isRefType :: Type Name -> Bool +isRefType tt + = case takePrimTyConApps tt of + Just (NameTyConFlow TyConFlowRef, [_]) -> True + _ -> False + + +-- | Check is some type is a fully applied type of a Vector. +isVectorType :: Type Name -> Bool +isVectorType tt + = case takePrimTyConApps tt of + Just (NameTyConFlow TyConFlowVector, [_]) -> True + _ -> False + + -- Compounds ------------------------------------------------------------------ tTuple1 :: Type Name -> Type Name tTuple1 tA = tApps (tConTyConFlow (TyConFlowTuple 1)) [tA] @@ -119,7 +182,19 @@ tRateNat :: Type Name -> Type Name -tRateNat tK = tApps (tConTyConFlow TyConFlowRateNat) [tK] +tRateNat tK = tApp (tConTyConFlow TyConFlowRateNat) tK + + +tDown :: Int -> Type Name -> Type Name +tDown n tK = tApp (tConTyConFlow $ TyConFlowDown n) tK + + +tTail :: Int -> Type Name -> Type Name +tTail n tK = tApp (tConTyConFlow $ TyConFlowTail n) tK + + +tProcess :: Type Name +tProcess = tConTyConFlow $ TyConFlowProcess -- Utils ---------------------------------------------------------------------- diff --git a/DDC/Core/Flow/Prim/TyConPrim.hs b/DDC/Core/Flow/Prim/TyConPrim.hs --- a/DDC/Core/Flow/Prim/TyConPrim.hs +++ b/DDC/Core/Flow/Prim/TyConPrim.hs @@ -5,7 +5,9 @@ , tBool , tNat , tInt - , tWord) + , tFloat + , tWord + , tVec) where import DDC.Core.Flow.Prim.Base import DDC.Core.Compounds.Simple @@ -25,6 +27,7 @@ PrimTyConWord _ -> kData PrimTyConFloat _ -> kData PrimTyConTag -> kData + PrimTyConVec _ -> kData `kFun` kData PrimTyConString -> kData @@ -40,18 +43,35 @@ -- | Primitive Nat# type. tNat :: Type Name -tNat = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConInt) kData) kData) +tNat = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConNat) kData) kData) -- | Primitive `Int#` type. tInt :: Type Name -tInt = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConInt) kData) kData) +tInt = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConInt) kData) kData) +-- | Primitive `FloatN#` type of the given width. +tFloat :: Int -> Type Name +tFloat bits + = TCon (TyConBound (UPrim (NamePrimTyCon (PrimTyConFloat bits)) kData) kData) + + -- | Primitive `WordN#` type of the given width. tWord :: Int -> Type Name tWord bits = TCon (TyConBound (UPrim (NamePrimTyCon (PrimTyConWord bits)) kData) kData) +-- | Primitive @VecN# a@. +tVec :: Int -> Type Name -> Type Name +tVec n tA = TApp (tConPrimTyCon (PrimTyConVec n)) tA + +-- Utils ---------------------------------------------------------------------- +tConPrimTyCon :: PrimTyCon -> Type Name +tConPrimTyCon tcp + = let k = kindPrimTyCon tcp + u = UPrim (NamePrimTyCon tcp) k + tc = TyConBound u k + in TCon tc diff --git a/DDC/Core/Flow/Procedure.hs b/DDC/Core/Flow/Procedure.hs --- a/DDC/Core/Flow/Procedure.hs +++ b/DDC/Core/Flow/Procedure.hs @@ -24,11 +24,7 @@ { procedureName :: Name , procedureParamTypes :: [BindF] , procedureParamValues :: [BindF] - , procedureNest :: Nest - , procedureStmts :: [LetsF] - , procedureResult :: ExpF - , procedureResultType :: TypeF } - + , procedureNest :: Nest } -- | A loop nest. data Nest @@ -37,6 +33,7 @@ | NestList { nestList :: [Nest]} + -- Used to define the outer loop of a process. | NestLoop { nestRate :: Type Name , nestStart :: [StmtStart] @@ -45,12 +42,23 @@ , nestEnd :: [StmtEnd] , nestResult :: Exp () Name } - | NestIf + -- Guarded context, + -- used when lowering pack-like operations. + | NestGuard { nestOuterRate :: Type Name , nestInnerRate :: Type Name , nestFlags :: Bound Name , nestBody :: [StmtBody] , nestInner :: Nest } + + -- Segmented context, + -- used when lowering segmented operations. + | NestSegment + { nestOuterRate :: Type Name + , nestInnerRate :: Type Name + , nestLength :: Bound Name + , nestBody :: [StmtBody] + , nestInner :: Nest } deriving Show @@ -70,13 +78,18 @@ -- | Statements that can appear at the start of a loop. -- These initialise accumulators. data StmtStart - -- Allocate a new vector. - = StartVecNew + -- | Evaluate a pure expression + = StartStmt + { startResultBind :: Bind Name + , startExpression :: Exp () Name } + + -- | Allocate a new vector. + | StartVecNew { startVecNewName :: Name , startVecNewElemType :: Type Name , startVecNewRate :: Type Name } - -- Inititlise a new accumulator. + -- | Inititlise a new accumulator. | StartAcc { startAccName :: Name , startAccType :: Type Name @@ -140,8 +153,7 @@ -- | Statements that appear after a loop to cleanup. data StmtEnd - -- | Pure ending statements to produce the result of - -- the overall process. + -- | Generic ending statements. = EndStmt { endBind :: Bind Name , endExp :: Exp () Name } @@ -152,10 +164,9 @@ , endType :: Type Name , endAccName :: Name } - -- | Destructively slice down a vector to its final size. - | EndVecSlice + -- | Destructively truncate a vector to its final size. + | EndVecTrunc { endVecName :: Name , endVecType :: Type Name , endVecRate :: Type Name } deriving Show - diff --git a/DDC/Core/Flow/Process.hs b/DDC/Core/Flow/Process.hs --- a/DDC/Core/Flow/Process.hs +++ b/DDC/Core/Flow/Process.hs @@ -1,6 +1,8 @@ module DDC.Core.Flow.Process ( Process (..) + , typeOfProcess + , Operator (..)) where import DDC.Core.Flow.Process.Process diff --git a/DDC/Core/Flow/Process/Operator.hs b/DDC/Core/Flow/Process/Operator.hs --- a/DDC/Core/Flow/Process/Operator.hs +++ b/DDC/Core/Flow/Process/Operator.hs @@ -29,95 +29,184 @@ } ----------------------------------------- - -- | Convert a series to a manifest vector. - | OpCreate - { -- | Binder for result vector - opResultVector :: BindF + -- | Flat replicate. + | OpRep + { -- Binder for result series. + opResultSeries :: BindF - -- | Rate of input series - , opInputRate :: TypeF + -- Rate of output series. + , opOutputRate :: TypeF - -- | Bound of input series. - , opInputSeries :: BoundF + -- Type of the elements. + , opElemType :: TypeF - -- | Rate that should be used when allocating the vector. - -- This is filled in by `patchAllocRates`. - , opAllocRate :: Maybe TypeF + -- Exp to compute the element to be replicated. + , opInputExp :: ExpF } - -- | Type of the elements. + ----------------------------------------- + -- | Segmented replicate. + | OpReps + { -- Binder for result series. + opResultSeries :: BindF + + -- Rate of input series. + , opInputRate :: TypeF + + -- Rate of output series. + , opOutputRate :: TypeF + + -- Type of the elements. , opElemType :: TypeF + + -- Bound for the segment descriptor. + , opSegdBound :: BoundF + + -- Bound for the input series. + , opInputSeries :: BoundF } + + ----------------------------------------- + -- | Segmented indices. + | OpIndices + { -- Binder for result series. + opResultSeries :: BindF + + -- Rate of input series. + , opInputRate :: TypeF + + -- Rate of output series. + , opOutputRate :: TypeF + + -- Bound for the segment descriptor. + , opSegdBound :: BoundF } + + ----------------------------------------- + -- | Fill a vector with elements from a series. + | OpFill + { -- Binder for result value (a Unit) + opResultBind :: BindF + + -- Bound of target vector. + , opTargetVector :: BoundF + + -- Rate of input series. + , opInputRate :: TypeF + + -- Bound of input series. + , opInputSeries :: BoundF + + -- Type of the elements. + , opElemType :: TypeF } + + ----------------------------------------- + -- | Gather elements from a vector into a series. + | OpGather + { -- Binder for result series. + opResultBind :: BindF + + -- Bound of source elem vector. + , opSourceVector :: BoundF + + -- Bound of source index series. + , opSourceIndices :: BoundF + + -- Rate of input and output series. + , opInputRate :: TypeF + + -- Type of gathered elements. + , opElemType :: TypeF } + ----------------------------------------- + -- | Scatter elements from a series into a vector. + | OpScatter + { -- Binder for result value (a Unit) + opResultBind :: BindF + -- Bound of target vector. + , opTargetVector :: BoundF + + -- Bound of source index series. + , opSourceIndices :: BoundF + + -- Bound of source element series. + , opSourceElems :: BoundF + + -- Rate of input serieses. + , opInputRate :: TypeF + + -- Type of elements. + , opElemType :: TypeF + } + ----------------------------------------- -- | Apply a function to corresponding elements in several input series -- of the same rate, producing a new series. This subsumes the regular -- 'map' operator as well as 'zipWith' like operators where the input -- lengths are identical. | OpMap - { -- | Arity of map, number of input streams. + { -- Arity of map, number of input streams. opArity :: Int - -- | Binder for result series. + -- Binder for result series. , opResultSeries :: BindF - -- | Rate of all input series. + -- Rate of all input series. , opInputRate :: TypeF - -- | Names for input series. + -- Names for input series. , opInputSeriess :: [BoundF] - -- | Worker input parameters + -- Worker input parameters , opWorkerParams :: [BindF] - -- | Worker body + -- Worker body , opWorkerBody :: ExpF } ----------------------------------------- - -- | Fold all the elements of a series. - | OpFold - { -- | Binder for result value. - opResultValue :: BindF + -- | Pack a series according to a selector. + | OpPack + { -- Binder for result series. + opResultSeries :: BindF - -- | Rate of input series. + -- Rate of input series. , opInputRate :: TypeF - -- | Bound of input series. + -- Bound of input series. , opInputSeries :: BoundF - -- | Starting accumulator value. - , opZero :: ExpF - - -- | Worker parameter for index input. - -- Should be BNone for OpFlowFold, but something for OpFlowFoldIndex - , opWorkerParamIndex :: BindF - - -- | Worker parameter for accumulator input. - , opWorkerParamAcc :: BindF - - -- | Worker parameter for element input. - , opWorkerParamElem :: BindF + -- Rate of output series. + , opOutputRate :: TypeF - -- | Worker body. - , opWorkerBody :: ExpF } + -- Type of a series element. + , opElemType :: TypeF } ----------------------------------------- - -- | Pack a series according to a selector. - | OpPack - { -- | Binder for result series. - opResultSeries :: BindF + -- | Reduce the elements of a series into a reference. + | OpReduce + { -- Binder for result value (a Unit) + opResultBind :: BindF - -- | Rate of input series. + -- Bound of target Ref. + , opTargetRef :: BoundF + + -- Rate of input series. , opInputRate :: TypeF - -- | Bound of input series. + -- Bound of input series. , opInputSeries :: BoundF - -- | Rate of output series. - , opOutputRate :: TypeF + -- Neutral element. + , opZero :: ExpF - -- | Type of a series element. - , opElemType :: TypeF } + -- Worker parameter for accumulator input. + , opWorkerParamAcc :: BindF + + -- Worker parameter for element input. + , opWorkerParamElem :: BindF + + -- Worker body. + , opWorkerBody :: ExpF + } deriving Show diff --git a/DDC/Core/Flow/Process/Pretty.hs b/DDC/Core/Flow/Process/Pretty.hs --- a/DDC/Core/Flow/Process/Pretty.hs +++ b/DDC/Core/Flow/Process/Pretty.hs @@ -3,14 +3,13 @@ import DDC.Core.Flow.Process.Process import DDC.Core.Flow.Process.Operator import DDC.Base.Pretty -import DDC.Type.Pretty () +import DDC.Core.Pretty () instance Pretty Process where ppr p = vcat $ [ ppr (processName p) - , text " result type: " <> ppr (processResultType p) , text " parameters: " <> ppr (processParamValues p) ] ++ map (indent 2 . ppr) (processOperators p) @@ -19,29 +18,71 @@ ppr op@OpId{} = vcat [ text "Id" - , text " rate: " <> ppr (opInputRate op) - , text " input: " <> ppr (opInputSeries op) - , text " result: " <> ppr (opResultSeries op) ] + , text " rate: " <> ppr (opInputRate op) + , text " input: " <> ppr (opInputSeries op) + , text " result: " <> ppr (opResultSeries op) ] - ppr op@OpCreate{} + ppr op@OpRep{} = vcat - [ text "Create" - , text " rate: " <> ppr (opInputRate op) - , text " input: " <> ppr (opInputSeries op) - , text " result: " <> ppr (opResultVector op) ] + [ text "Rep" + , text " result: " <> ppr (opResultSeries op) + , text " output rate: " <> ppr (opOutputRate op) + , text " type: " <> ppr (opElemType op) ] - ppr op@OpMap{} + ppr op@OpReps{} = vcat - [ text "Map" - , text " rate: " <> ppr (opInputRate op) ] + [ text "Reps" + , text " result: " <> ppr (opResultSeries op) + , text " input rate: " <> ppr (opInputRate op) + , text " output rate: " <> ppr (opOutputRate op) + , text " type: " <> ppr (opElemType op) + , text " segd: " <> ppr (opSegdBound op) + , text " input: " <> ppr (opInputSeries op) ] + + ppr op@OpIndices{} + = vcat + [ text "Indices" + , text " result: " <> ppr (opResultSeries op) + , text " input rate: " <> ppr (opInputRate op) + , text " output rate: " <> ppr (opOutputRate op) ] - ppr op@OpFold{} + ppr op@OpFill{} = vcat - [ text "Fold" - , text " rate: " <> ppr (opInputRate op) ] + [ text "Fill" + , text " target: " <> ppr (opTargetVector op) + , text " input: " <> ppr (opInputSeries op) ] + ppr op@OpGather{} + = vcat + [ text "Gather" + , text " result: " <> ppr (opResultBind op) + , text " vector: " <> ppr (opSourceVector op) + , text " indices: " <> ppr (opSourceIndices op) + , text " rate: " <> ppr (opInputRate op) + , text " type: " <> ppr (opElemType op) ] + + ppr op@OpScatter{} + = vcat + [ text "Scatter" + , text " vector: " <> ppr (opTargetVector op) + , text " indices: " <> ppr (opSourceIndices op) + , text " elems: " <> ppr (opSourceElems op) + , text " rate: " <> ppr (opInputRate op) + , text " type: " <> ppr (opElemType op) ] + + ppr op@OpReduce{} + = vcat + [ text "Reduce" + , text " rate: " <> ppr (opInputRate op) + , text " input: " <> ppr (opInputSeries op) ] + + ppr op@OpMap{} + = vcat + [ text "Map" + , text " rate: " <> ppr (opInputRate op) ] + ppr op@OpPack{} = vcat [ text "Pack" - , text " input rate: " <> ppr (opInputRate op) - , text " output rate: " <> ppr (opOutputRate op) ] + , text " input rate: " <> ppr (opInputRate op) + , text " output rate: " <> ppr (opOutputRate op) ] diff --git a/DDC/Core/Flow/Process/Process.hs b/DDC/Core/Flow/Process/Process.hs --- a/DDC/Core/Flow/Process/Process.hs +++ b/DDC/Core/Flow/Process/Process.hs @@ -1,18 +1,17 @@ module DDC.Core.Flow.Process.Process - (Process (..)) + ( Process (..) + , typeOfProcess) where import DDC.Core.Flow.Process.Operator +import DDC.Core.Flow.Compounds import DDC.Core.Flow.Context import DDC.Core.Flow.Prim import DDC.Core.Flow.Exp --- | A process applies some series operators and produces some non-series --- result. --- --- We get one of these for each top-level series function in the --- original program. +-- | A process is a graph of series operators that read from some parameter +-- series and write to some accumulators. data Process = Process { -- | Name of whole process. @@ -36,20 +35,16 @@ -- | Flow operators in this process. , processOperators :: [Operator] + } - -- | Top-level statements that don't invoke stream operators. - -- These are typically statements that combine reduction results, - -- like the addition in (fold (+) 0 s1 + fold (*) 1 s1). - -- - -- INVARIANT: - -- The worker functions for stream operators do not mention - -- any of the bound variables. - , processStmts :: [LetsF] - -- Type of process result - , processResultType :: TypeF +-- | Take the functional type of a process. +typeOfProcess :: Process -> TypeF +typeOfProcess process + = let tBody = foldr tFun tProcess + $ map typeOfBind (processParamValues process) - -- Final result of process. - , processResult :: ExpF - } + tQuant = foldr TForall tBody + $ processParamTypes process + in tQuant diff --git a/DDC/Core/Flow/Profile.hs b/DDC/Core/Flow/Profile.hs --- a/DDC/Core/Flow/Profile.hs +++ b/DDC/Core/Flow/Profile.hs @@ -25,13 +25,10 @@ { profileName = "Flow" , profileFeatures = features , profilePrimDataDefs = primDataDefs - , profilePrimSupers = primSortEnv , profilePrimKinds = primKindEnv , profilePrimTypes = primTypeEnv - - -- We don't need to distinguish been boxed and unboxed - -- because we allow unboxed instantiation. - , profileTypeIsUnboxed = const False } + , profileTypeIsUnboxed = const False + , profileNameIsHole = Nothing } features :: Features @@ -41,6 +38,7 @@ , featuresTrackedClosures = False , featuresFunctionalEffects = False , featuresFunctionalClosures = False + , featuresEffectCapabilities = False , featuresPartialPrims = True , featuresPartialApplication = True , featuresGeneralApplication = True diff --git a/DDC/Core/Flow/Transform/Concretize.hs b/DDC/Core/Flow/Transform/Concretize.hs --- a/DDC/Core/Flow/Transform/Concretize.hs +++ b/DDC/Core/Flow/Transform/Concretize.hs @@ -26,30 +26,72 @@ concretizeX _kenv tenv xx -- loop# -> loopn# - | Just ( NameOpLoop OpLoopLoop + -- using an existing RateNat in the environment. + | Just ( NameOpControl OpControlLoop , [XType tK, xF]) <- takeXPrimApps xx + , Just nRN <- findRateNatWithRate tenv tK + , xRN <- XVar (UName nRN) + = Just + $ xLoopN tK xRN xF + + -- loop# -> loopn# + -- using the length of a series to get the rate. + | Just ( NameOpControl OpControlLoop + , [XType tK, xF]) <- takeXPrimApps xx , Just (nS, _, tA) <- findSeriesWithRate tenv tK , xS <- XVar (UName nS) = Just - $ xLoopLoopN + $ xLoopN tK -- type level rate (xRateOfSeries tK tA xS) -- xF -- loop body - -- newVectorR# -> newVectorN# + -- newVectorR# -> newVector# | Just ( NameOpStore OpStoreNewVectorR , [XType tA, XType tK]) <- takeXPrimApps xx , Just (nS, _, tS) <- findSeriesWithRate tenv tK , xS <- XVar (UName nS) = Just - $ xNewVectorN - tA tK - (xRateOfSeries tK tS xS) + $ xNewVector + tA + (xNatOfRateNat tK $ xRateOfSeries tK tS xS) | otherwise = Nothing +------------------------------------------------------------------------------- +-- | Search the given environment for the name of a RateNat with the +-- given rate parameter. We only look at named binders. +findRateNatWithRate + :: TypeEnvF -- ^ Type Environment. + -> Type Name -- ^ Rate type. + -> Maybe Name + -- ^ RateNat name +findRateNatWithRate tenv tR + = go (Map.toList (Env.envMap tenv)) + where go [] = Nothing + go ((n, tRN) : moar) + | isRateNatTypeOfRate tR tRN = Just n + | otherwise = go moar + + +-- | Check whether some type is a RateNat type of the given rate. +isRateNatTypeOfRate + :: Type Name -> Type Name + -> Bool + +isRateNatTypeOfRate tR tRN + | Just ( NameTyConFlow TyConFlowRateNat + , [tR']) <- takePrimTyConApps tRN + , tR == tR' + = True + + | otherwise + = False + + +------------------------------------------------------------------------------- -- | Search the given environment for the name of a series with the -- given rate parameter. We only look at named binders. findSeriesWithRate @@ -59,8 +101,7 @@ -- ^ Series name, rate type, element type. findSeriesWithRate tenv tR = go (Map.toList (Env.envMap tenv)) - where - go [] = Nothing + where go [] = Nothing go ((n, tS) : moar) = case isSeriesTypeOfRate tR tS of Nothing -> go moar diff --git a/DDC/Core/Flow/Transform/Extract.hs b/DDC/Core/Flow/Transform/Extract.hs --- a/DDC/Core/Flow/Transform/Extract.hs +++ b/DDC/Core/Flow/Transform/Extract.hs @@ -1,8 +1,8 @@ module DDC.Core.Flow.Transform.Extract - (extractModule) + ( extractModule + , extractProcedure) where -import DDC.Core.Flow.Transform.Extract.Intersperse import DDC.Core.Flow.Compounds import DDC.Core.Flow.Procedure import DDC.Core.Flow.Prim @@ -27,34 +27,31 @@ -- | Extract code for a whole procedure. extractProcedure :: Procedure -> (Bind Name, ExpF) -extractProcedure (Procedure n bsParam xsParam nest stmts xResult tResult) - = let tBody = foldr tFun tResult $ map typeOfBind xsParam - tQuant = foldr TForall tBody $ bsParam +extractProcedure (Procedure n bsParam xsParam nest) + = let tBody = foldr tFun tUnit $ map typeOfBind xsParam + tQuant = foldr TForall tBody $ bsParam in ( BName n tQuant , xLAMs bsParam $ xLams xsParam - $ extractNest nest stmts xResult ) + $ extractNest nest xUnit ) ------------------------------------------------------------------------------- -- | Extract code for a loop nest. extractNest :: Nest -- ^ Loops to run in sequence. - -> [LetsF] -- ^ Baseband statements from the source program - -- that run after the loop operators. -> ExpF -- ^ Final result of procedure. -> ExpF -extractNest nest stmts xResult - = let stmts' = intersperseStmts (extractLoop nest) stmts - in xLets stmts' xResult +extractNest nest xResult + = xLets (extractLoop nest) xResult ------------------------------------------------------------------------------- -- | Extract code for a possibly nested loop. extractLoop :: Nest -> [LetsF] --- Code in a loop context. +-- Code in the top-level loop context. extractLoop (NestLoop tRate starts bodys inner ends _result) = let -- Starting statements. @@ -62,8 +59,8 @@ -- The loop itself. lLoop = LLet (BNone tUnit) - (xApps (XVar (UPrim (NameOpLoop OpLoopLoop) - (typeOpLoop OpLoopLoop))) + (xApps (XVar (UPrim (NameOpControl OpControlLoop) + (typeOpControl OpControlLoop))) [ XType tRate -- loop rate , xBody ]) -- loop body @@ -83,31 +80,56 @@ in lsStart ++ [lLoop] ++ lsEnd --- Code in a select / if context. -extractLoop (NestIf _tRateOuter tRateInner uFlags stmtsBody nested) +-- Code in a guard context. +extractLoop (NestGuard _tRateOuter tRateInner uFlags stmtsBody nested) = let -- Get the name of a single flag from the series of flags. UName nFlags = uFlags nFlag = NameVarMod nFlags "elem" xFlag = XVar (UName nFlag) - -- Make a name for the counter. + -- Get the name of the entry counter. TVar (UName nK) = tRateInner uCounter = UName (NameVarMod nK "count") - xGuard = xLoopGuard xFlag (XVar uCounter) + xBody = xGuard (XVar uCounter) xFlag ( XLam (BAnon tNat) $ xLets (lsBody ++ lsNested) xUnit) - -- Selector context. - lsBody = concatMap extractStmtBody stmtsBody + -- Statements in the guard context. + lsBody = concatMap extractStmtBody stmtsBody -- Nested contexts. - lsNested = extractLoop nested + lsNested = extractLoop nested - in [LLet (BNone tUnit) xGuard] + in [LLet (BNone tUnit) xBody] +-- Code in a segment context. +extractLoop (NestSegment _tRateOuter tRateInner uLengths stmtsBody nested) + = let + -- Get the name of a single segment length from the series of lengths. + UName nLengths = uLengths + nLength = NameVarMod nLengths "elem" + xLength = XVar (UName nLength) + -- Get the name of the entry counter. + TVar (UName nK) = tRateInner + uCounter = UName (NameVarMod nK "count") + + xBody = xSegment (XVar uCounter) xLength + ( XLam (BAnon tNat) -- Index into current segment. + $ XLam (BAnon tNat) -- Index into overall result series. + $ xLets (lsBody ++ lsNested) xUnit) + + -- Statements in the segment context. + lsBody = concatMap extractStmtBody stmtsBody + + -- Nested contexts. + lsNested = extractLoop nested + + in [LLet (BNone tUnit) xBody] + + extractLoop NestEmpty = [] @@ -121,7 +143,11 @@ extractStmtStart :: StmtStart -> [LetsF] extractStmtStart ss = case ss of - -- Allocate a new vector + -- Evaluate a pure expression. + StartStmt b x + -> [LLet b x] + + -- Allocate a new vector. StartVecNew nVec tElem tRate' -> [LLet (BName nVec (tVector tElem)) (xNewVectorR tElem tRate') ] @@ -171,19 +197,19 @@ -> [LLet (BName n t) (xRead t (XVar (UName nAcc))) ] - -- Slice. - EndVecSlice nVec tElem tRate + -- Truncate a vector down to its final size. + EndVecTrunc nVec tElem tRate -> let -- Get the name of the counter. TVar (UName nK) = tRate uCounter = UName (NameVarMod nK "count") - xCounter = xRead tInt (XVar uCounter) + xCounter = xRead tNat (XVar uCounter) xVec = XVar (UName nVec) -- Read the counter in a let since it will need to be threaded - in [ LLet (BAnon tInt) + in [ LLet (BAnon tNat) xCounter - , LLet (BName nVec (tVector tElem)) - (xSliceVector tElem (XVar (UIx 0)) xVec) ] + , LLet (BNone tUnit) + (xTruncVector tElem (XVar (UIx 0)) xVec) ] diff --git a/DDC/Core/Flow/Transform/Extract/Intersperse.hs b/DDC/Core/Flow/Transform/Extract/Intersperse.hs deleted file mode 100644 --- a/DDC/Core/Flow/Transform/Extract/Intersperse.hs +++ /dev/null @@ -1,53 +0,0 @@ - -module DDC.Core.Flow.Transform.Extract.Intersperse - (intersperseStmts) -where -import DDC.Core.Flow.Compounds -import DDC.Core.Flow.Prim -import DDC.Core.Flow.Exp -import DDC.Core.Collect -import DDC.Core.Transform.Annotate -import DDC.Type.Env -import Data.List (partition, (\\)) -import qualified Data.Set as Set - - --- | Given two lists of lets, order them so that any variables are bound before use. -intersperseStmts :: [LetsF] -> [LetsF] -> [LetsF] -intersperseStmts ls rs - = let bls = nubbish $ map takeSubstBoundsOfBinds $ map valwitBindsOfLets ls - brs = nubbish $ map takeSubstBoundsOfBinds $ map valwitBindsOfLets rs - in intersperse' (ls `zip` bls ++ rs `zip` brs) - - --- Because a name might be bound a couple of times --- (see extractStmtEnd:EndVecSlice) -nubbish :: [[Bound Name]] -> [[Bound Name]] -nubbish bs' = go bs' [] - where go [] _ = [] - go (b:bs) accs = (b \\ accs) : go bs (accs ++ b) - - -intersperse' - :: [(Lets () Name, [Bound Name])] - -> [Lets () Name] - -intersperse' [] = [] - -intersperse' ((x,b):bxs) - -- Check if any of the free variables in x are bound later on. - -- If so, defer this binding... - | f <- freeXLets x - , (r:rs,os) <- partition (any (flip Set.member f) . snd) bxs - , (x', _) <- r - = x' : intersperse' (rs ++ (x, b) : os) - - -- Otherwise it's a valid binding - | otherwise - = x : intersperse' bxs - - -freeXLets :: LetsF -> Set.Set (Bound Name) -freeXLets ll - = freeX empty $ annotate () (XLet ll (XCon (dcBool True))) - diff --git a/DDC/Core/Flow/Transform/Melt.hs b/DDC/Core/Flow/Transform/Melt.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Melt.hs @@ -0,0 +1,169 @@ + +module DDC.Core.Flow.Transform.Melt + ( Info (..) + , meltModule ) +where +import DDC.Core.Flow.Prim +import DDC.Core.Flow.Exp +import DDC.Core.Flow.Compounds +import DDC.Core.Module +import DDC.Core.Transform.Annotate +import DDC.Core.Transform.Deannotate +import Control.Monad.Writer.Strict +import qualified Data.Set as Set +import Data.Set (Set) + +------------------------------------------------------------------------------- +-- | Contains binders of variables that have been melted. +data Info + = Info (Set Name) + +instance Monoid Info where + mempty = Info (Set.empty) + mappend (Info s1) (Info s2) = Info (Set.union s1 s2) + + +------------------------------------------------------------------------------- +-- | Melt compound data structures in a module. +meltModule :: Module () Name -> (Module () Name, Info) +meltModule mm + = let (xBody', info) + = runWriter + $ melt + $ deannotate (const Nothing) $ moduleBody mm + + in (mm { moduleBody = annotate () xBody' }, info) + + +------------------------------------------------------------------------------- +class Melt c where + melt :: c -> Writer Info c + + +-- Exp ------------------------------------------------------------------------ +instance Melt (Exp () Name) where + + -- Melt allocations of tuple references. + -- + -- let b = new [TupleN# tA1 tA2] xInit in ... + -- + -- => let b$1 = new [tA1] (projN_1 xInit) in + -- let b$2 = new [tA2] (projN_2 xInit) in ... + -- + melt (XLet (LLet b x1) x2) + | BName nBind _t <- b + , Just ( NameOpStore OpStoreNew + , [XType tElem, xInit]) <- takeXPrimApps x1 + , Just ( NameTyConFlow (TyConFlowTuple n) + , tAs) <- takePrimTyConApps tElem + , length tAs == n + = do + let ltsNew + = [ LLet (BName (NameVarMod nBind (show i)) (tRef tA)) + $ xNew tA (xProj tAs i xInit) + | i <- [1..n] + | tA <- tAs ] + + x2' <- melt x2 + return $ xLets ltsNew x2' + + + -- Melt reads from tuple references. + -- + -- let b = read# [TupleN# tA1 tA2] xR in ... + -- + -- => let b.1 = read# [tA1] xRef$1 in + -- let b.2 = read# [tA2] xRef$2 in + -- let b = TN# [tA1] [tA2] b$1 b$2 in ... + -- + melt (XLet (LLet b x1) x2) + | BName nBind _t <- b + , Just ( NameOpStore OpStoreRead + , [XType tElem, XVar (UName nRef)]) <- takeXPrimApps x1 + , Just ( NameTyConFlow (TyConFlowTuple n) + , tsA) <- takePrimTyConApps tElem + , length tsA == n + = do + -- read all the components + let ltsRead + = [LLet (BName (NameVarMod nBind (show i)) tA) + $ xRead tA + (XVar (UName (NameVarMod nRef (show i)))) + | i <- [1..n] + | tA <- tsA ] + + -- build the result tuple + let ltOrig + = LLet b + $ xApps (XCon (dcTupleN n)) + ( [XType t | t <- tsA] + ++ [XVar (UName (NameVarMod nBind (show i))) + | i <- [1..n]]) + + -- melt the body + x2' <- melt x2 + + return $ xLets (ltsRead ++ [ltOrig]) x2' + + + -- Melt writes to tuple references. + -- + -- let _ = write# [TupleN# tA1 tA2] xR xV in ... + -- + -- => let _ = write# [tA1] xR$1 (projN_1 xV) + -- let _ = write# [tA2] xR$2 (projN_2 xV) in ... + -- + melt (XLet (LLet b x1) x2) + | BNone tB <- b + , Just ( NameOpStore OpStoreWrite + , [XType tElem, XVar (UName nRef), xV]) <- takeXPrimApps x1 + , Just ( NameTyConFlow (TyConFlowTuple n) + , tsA) <- takePrimTyConApps tElem + , length tsA == n + = do + let ltsWrite + = [ LLet (BNone tB) + $ xWrite tA + (XVar (UName (NameVarMod nRef (show i)))) + (xProj tsA i xV) + | i <- [1..n] + | tA <- tsA ] + + x2' <- melt x2 + return $ xLets ltsWrite x2' + + + -- Boilerplate + melt xx + = case xx of + XAnnot a x -> liftM (XAnnot a) (melt x) + XLet lts x -> liftM2 XLet (melt lts) (melt x) + XApp x1 x2 -> liftM2 XApp (melt x1) (melt x2) + XVar u -> return $ XVar u + XCon dc -> return $ XCon dc + XLAM b x -> liftM (XLAM b) (melt x) + XLam b x -> liftM (XLam b) (melt x) + XCase x alts -> liftM2 XCase (melt x) (mapM melt alts) + XCast c x -> liftM (XCast c) (melt x) + XType t -> return $ XType t + XWitness w -> return $ XWitness w + + +-- Lets ----------------------------------------------------------------------- +instance Melt (Lets () Name) where + melt lts + = case lts of + LLet b x -> liftM (LLet b) (melt x) + LRec bxs + -> do let (bs, xs) = unzip bxs + xs' <- mapM melt xs + return $ LRec $ zip bs xs' + + LPrivate{} -> return lts + LWithRegion{} -> return lts + + +-- Alt ------------------------------------------------------------------------ +instance Melt (Alt () Name) where + melt (AAlt w x) = liftM (AAlt w) (melt x) + diff --git a/DDC/Core/Flow/Transform/Prep.hs b/DDC/Core/Flow/Transform/Prep.hs deleted file mode 100644 --- a/DDC/Core/Flow/Transform/Prep.hs +++ /dev/null @@ -1,169 +0,0 @@ - -module DDC.Core.Flow.Transform.Prep - (prepModule) -where -import DDC.Core.Flow.Prim -import DDC.Core.Flow.Prim.TyConPrim -import DDC.Core.Compounds -import DDC.Core.Module -import DDC.Core.Exp -import Control.Monad.State.Strict -import Data.Map (Map) -import qualified Data.Map as Map -import DDC.Type.Env (TypeEnv) -import qualified DDC.Type.Env as Env - - --- | Prepare a module for lowering. --- We need all worker functions passed to flow operators to be eta-expanded --- and for their parameters to have real names. -prepModule - :: Module a Name - -> (Module a Name, Map Name [Type Name]) - -prepModule mm - = do runState (prepModuleM mm) Map.empty - - -prepModuleM :: Module a Name -> PrepM (Module a Name) -prepModuleM mm - = do xBody' <- prepX Env.empty $ moduleBody mm - return $ mm { moduleBody = xBody' } - - --- Do a bottom-up rewrite, --- on the way up remember names of variables that are passed as workers --- to flow operators, then eta-expand bindings with those names. --- Record the environment of let-bound expressions, to know whether to --- eta-expand in their definition or at the callsite. -prepX :: TypeEnv Name -> Exp a Name -> PrepM (Exp a Name) -prepX tenv xx - = let down = prepX tenv - in case xx of - -- MapN - XApp{} - | Just (XVar _ u, xsArgs) <- takeXApps xx - , UPrim (NameOpFlow (OpFlowMap n)) _ <- u - , _xTR : xsArgs2 <- xsArgs - , (xsA, xsArgs3) <- splitAt (n + 1) xsArgs2 - , tsA <- [t | XType t <- xsA] - , XVar _ (UName nWorker) : _ <- xsArgs3 - , Env.member (UName nWorker) tenv - -> do addWorkerArgs nWorker (take n tsA) - return xx - - -- Worker passed to map, but not let-bound. - -- Eta-expand in-place. - XApp{} - | Just (xmap@(XVar _ u), args@[_, XType tA, XType _tB, f@(XVar a _), _]) - <- takeXApps xx - , UPrim (NameOpFlow (OpFlowMap 1)) _ <- u - -> do let f' = xEtaExpand a f [tA] - args' = take 3 args ++ [f'] ++ [last args] - return $ xApps a xmap args' - - -- Detect workers passed to folds. - XApp{} - | Just (XVar _ u, [_, XType tA, XType tB, XVar _ (UName n), _, _]) - <- takeXApps xx - , UPrim (NameOpFlow OpFlowFold) _ <- u - -> do addWorkerArgs n [tA, tB] - return xx - - -- FoldIndex - XApp{} - | Just (XVar _ u, [_, XType tA, XType tB, XVar _ (UName n), _, _]) - <- takeXApps xx - , UPrim (NameOpFlow OpFlowFoldIndex) _ <- u - -> do addWorkerArgs n [tInt, tA, tB] - return xx - - -- Detect workers passed to mkSels - XApp{} - | Just (XVar _ u, [XType _tK1, XType _tA, _, XVar _ (UName n)]) - <- takeXApps xx - , UPrim (NameOpFlow (OpFlowMkSel _)) _ <- u - -> do addWorkerArgs n [] - return xx - - -- Bottom-up transform boilerplate. - XVar{} -> return xx - XCon{} -> return xx - XLAM a b x -> liftM3 XLAM (return a) (return b) (down x) - XLam a b x -> liftM3 XLam (return a) (return b) (down x) - XApp a x1 x2 -> liftM3 XApp (return a) (down x1) (down x2) - - XLet a lts x - -> do -- Slurp binds from lets, add to tenv - let tenv' = Env.extends (valwitBindsOfLets lts) tenv - x' <- prepX tenv' x - - -- Use old tenv for the binders - lts' <- prepLts tenv a lts - return $ XLet a lts' x' - - XCase a x alts -> liftM3 XCase (return a) (down x) (mapM (prepAlt tenv) alts) - XCast a c x -> liftM3 XCast (return a) (return c) (down x) - XType{} -> return xx - XWitness{} -> return xx - - --- Prepare let bindings for lowering. -prepLts :: TypeEnv Name -> a -> Lets a Name -> PrepM (Lets a Name) -prepLts tenv a lts - = case lts of - LLet b@(BName n _) x - -> do x' <- prepX tenv x - - mArgs <- lookupWorkerArgs n - case mArgs of - Just tsArgs - | length tsArgs > 0 - -> return $ LLet b $ xEtaExpand a x' tsArgs - - _ -> return $ LLet b x' - - LLet b x - -> do x' <- prepX tenv x - return $ LLet b x' - - LRec bxs - -> do let (bs, xs) = unzip bxs - let tenv' = Env.extends bs tenv - xs' <- mapM (prepX tenv') xs - return $ LRec $ zip bs xs' - - LLetRegions{} -> return lts - LWithRegion{} -> return lts - - --- Prepare case alternative for lowering. -prepAlt :: TypeEnv Name -> Alt a Name -> PrepM (Alt a Name) -prepAlt tenv (AAlt w x) - = liftM (AAlt w) (prepX tenv x) - - -xEtaExpand :: a -> Exp a Name -> [Type Name] -> Exp a Name -xEtaExpand a x tys - = xLams a (map BAnon tys) - $ xApps a x [ XVar a (UIx (length tys - 1 - ix)) - | ix <- [0 .. length tys - 1] ] - - --- State ---------------------------------------------------------------------- -type PrepS = Map Name [Type Name] -type PrepM = State PrepS - - --- | Record this name as being of a worker function. -addWorkerArgs :: Name -> [Type Name] -> PrepM () -addWorkerArgs name tsParam - = modify $ Map.insert name tsParam - - --- | Check whether this name corresponds to a worker function. -lookupWorkerArgs :: Name -> PrepM (Maybe [Type Name]) -lookupWorkerArgs name - = do names <- get - return $ Map.lookup name names - diff --git a/DDC/Core/Flow/Transform/Rates/Constraints.hs b/DDC/Core/Flow/Transform/Rates/Constraints.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Rates/Constraints.hs @@ -0,0 +1,351 @@ +module DDC.Core.Flow.Transform.Rates.Constraints + ( Constraint(..) + , ConstraintMap, EquivClass + , canonName + , checkBindConstraints + , getMaxSize ) +where +import DDC.Core.Flow.Compounds +import DDC.Core.Flow.Prim +import DDC.Core.Flow.Exp +import DDC.Core.Flow.Transform.Rates.Fail +import Control.Monad +import qualified Data.Map as Map +import qualified Data.Set as Set + + + +-- | Constraint information +-- An equal can have multiple - eg map3 +-- Filtered only has its source input +data Constraint + = ConEqual [Name] + | ConFiltered Name + deriving (Eq,Show) + +type ConstraintMap = Map.Map Name Constraint +type EquivClass = [Set.Set Name] + + +-- | Get canonical name for given equivalence class +-- Return original if there is none +-- (for example, a filter with no maps applied would have none since equiv classes are only built from maps) +canonName :: EquivClass -> Name -> Name +canonName equivs n + = case equivSet equivs n of + Nothing -> n + Just s -> Set.findMin s + + +-- | Get set of associated names in given equivalence class +equivSet :: EquivClass -> Name -> Maybe (Set.Set Name) +equivSet equivs n = go equivs + where + -- No classes left, not found + go [] + = Nothing + + -- If @n@ is a member of this class, return it + go (c:cs') + | Set.member n c + = Just c + + -- Check the rest + | otherwise + = go cs' + + +-- | Check constraints for a single function body's bindings. +-- The bindings must be in a-normal form. +checkBindConstraints :: [(Name,ExpF)] -> LogFailures (ConstraintMap, EquivClass) +checkBindConstraints binds + = -- Generate all constraints + let constrs = getConstraints binds + -- Squash down eqs into equivalence classes + equivs = equivConstrs constrs + -- Get filter constraints as pairs + filts = filterConstrs constrs equivs + + -- Check for ill-formed constraints: + -- Filter "a <= a" is bad, as restricts to a=a + -- Filter "a <= b" and "a <= c" is bad because 'a' mentioned twice in lhs + in checkFilters filts >> return (constrs, equivs) + + +getMaxSize :: ConstraintMap -> EquivClass -> [Name] -> Name -> Name +getMaxSize constrs equivs mans get + = let get' = upFiltered get + in getFromMans get' + where + -- Keep moving up through filtered constraints until we hit the top + upFiltered g + | Just eqs <- equivSet equivs g + = upFiltered' g (Set.toList eqs) + | otherwise + = g + + upFiltered' g [] + = g + upFiltered' g (e:es) + | Just (ConFiltered g') <- Map.lookup e constrs + = upFiltered g' + | otherwise + = upFiltered' g es + + -- Find a manifest vector in the same equivalence class + getFromMans g + = let e = canonName equivs g + in getFromMans' e mans + + getFromMans' g [] + = g + getFromMans' g (m:ms) + | g == canonName equivs m + = m + | otherwise + = getFromMans' g ms + + + +-- | Squash constraints into equivalence classes +-- I'm sure this could be smarter. +equivConstrs :: ConstraintMap -> EquivClass +equivConstrs m + = let sets = filter (not . Set.null) + $ map gen + $ Map.toList m + in squash sets [] + where + -- Simply generate a set from each constraint + gen (k, (ConEqual eqs)) + = Set.fromList (k:eqs) + -- Ignore filter constraints + gen (k, (ConFiltered _from)) + = Set.singleton k + + -- Squash constraint sets together + squash [] acc + = acc + + squash (a:as) acc + -- Try to merge the @a@ set into @acc@ somewhere + -- If so, start merging the whole thing again + | Just merged <- squash_merge a acc + = squash (merged ++ as) [] + + -- Nothing in @a@ is mentioned in @acc@, so no merging required: + -- just add this set to the accumulator + | otherwise + = squash as (a:acc) + + squash_merge ins (s:ss) + -- Check if any members of @ins@ are mentioned in @s@ + -- If so, merge them into one equivalence class + | not $ Set.null $ ins `Set.intersection` s + = Just (ins `Set.union` s : ss) + + -- Check if there is a chance to merge later + | Just ss' <- squash_merge ins ss + = Just (s : ss') + + -- No merge is possible + squash_merge _ins _ss + = Nothing + + +-- Get canonical names of all filter constraints +filterConstrs :: ConstraintMap -> EquivClass -> [(Name,Name, Name, Name)] +filterConstrs m equivs = Map.foldWithKey go [] m + where + go k (ConFiltered src) ms + = (canonName equivs k, canonName equivs src, k, src) : ms + go _ _ ms + = ms + + +-- | Generate constraints map from bindings +getConstraints :: [(Name,ExpF)] -> ConstraintMap +getConstraints lets + = foldl go Map.empty lets + where + go m (n,x) + | Just (n',c) <- getConstraint n x + = Map.insert n' c m + | otherwise + = m + +getConstraint :: Name -> ExpF -> Maybe (Name, Constraint) +getConstraint n xx + | Just (f, args) <- takeXApps xx + , XVar (UPrim (NameOpVector ov) _) <- f + = case ov of + OpVectorMap i + -- Args: + -- map1 :: [a b : *]. (a -> b) -> Vector a -> Vector b + -- (drop 3) + -- map2 :: [a b c : *]. (a -> b -> c) -> Vector a -> Vector b -> Vector c + -- (drop 4) + | vecs <- drop (i+2) args + -- Must be fully applied + , length vecs == i + , names <- getNames vecs + -- Each name must also be a bound variable + , length names == i + -> Just (n, ConEqual names) + + OpVectorFilter + | [_tyA, _p, XVar (UName vec)] <- args + -> Just (n, ConFiltered vec) + + OpVectorGenerate + -- Not really sure about this + -> Just (n, ConEqual []) + + OpVectorReduce + | [_tyA, _f, _z, XVar (UName vec)] <- args + -> Just (n, ConEqual [vec]) + + OpVectorLength + | [_tyA, XVar (UName vec)] <- args + -> Just (n, ConEqual [vec]) + + _ + -> Nothing + + | otherwise + = Nothing + +-- | Get bound name for each expression +-- All expressions must be variables of bound names, +-- otherwise result list will be shorter than input. +getNames :: [ExpF] -> [Name] +getNames vs + = concatMap get vs + where + get x + | XVar (UName v) <- x + = [v] + | otherwise + = [] + + +-- | Check for ill-formed constraints: +--- +-- Filter 'a <= a' is bad, as restricts to 'a=a' +-- Filter 'a <= b' and 'a <= c' is bad because a mentioned twice in lhs +-- For some filter +-- > bs = filter p as +-- the arguments are +-- > (canon bs, canon as, bs, as) +-- the 'raw' variable names bs and as are only used for error messages; +-- comparisons are done on canonical names. +checkFilters :: [(Name,Name, Name,Name)] -> LogFailures () +checkFilters cs + = go cs + where + go [] + = return () + go ((lc,rc, ln, rn):cs') + = do when (lc == rc) $ + warn $ FailConstraintFilteredLessFiltered ln rn + -- Check against later ones + forM_ cs' $ \(lc', _, ln', _) -> + when (lc == lc') $ + warn $ FailConstraintFilteredNotUnique ln ln' + + go cs' + + + +{- + +f = \(as : Vector a). + as' = vmap [:a b:] g as + return as' + +==> +[as=as'] +==> + +f = \(as : Vector a). + runSeries as /\(k1 : Rate). \(asS : Series k1 a). + as' = valloc [:k1 b:] + as'S = smap [:k1 a b:] g asS + sfill [:k1 b:] as' as'S + return as' + +--- + +f = \(as : Vector a). + as' = vmap [:a b:] g as + as'' = vmap [:b b:] h as' + return as'' + +==> +[as = as' = as''] +==> + +f = \(as : Vector a). + runSeries as /\(k1 : Rate). \(asS : Series k1 a). + as'S = smap [:k1 a b:] g asS + as'' = valloc [:k1 c:] + as''S = smap [:k1 b c:] h as'S + sfill [:k1 b:] as'' as''S + return as'' + +--- + +f = \(as : Vector a). + as' = filter p as + n = length as' + ns = map (/n) as' + +==> +[as' <= as +,ns = as'] +==> + +f = \(as : Vector a). + runSeries as /\(k1 : Rate). \(asS : Series k1 a). + as'F = smap [:k1 a Bool:] p asS + mkSel [:k1:] as'F /\(k2 : Rate). \(as'Se : Sel k1 k2). + as'S = spack [:k1 k2 a:] as'Se asS + n = slength [:k2:] + nsS = smap [:k2 a a:] (/n) as'S + ns = valloc [:k2 a:] + sfill [:k2 a:] ns nsS + + return ns + +--- + +f = \(as : Vector a). + bs = filter p as + cs = map2 f as bs + return cs + +==> +[bs <= as +,cs = as = bs] +==> +[as <= as] +Error! + +--- + +f = \(as bs : Vector a). + cs = filter p as + ds = filter p bs + es = map2 f cs ds + return es + +==> +[cs <= as +,ds <= bs +,cs=ds=es] +==> +[cs <= as +,cs <= bs] +Error, cs mentioned twice in lhs! +-} + diff --git a/DDC/Core/Flow/Transform/Rates/Fail.hs b/DDC/Core/Flow/Transform/Rates/Fail.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Rates/Fail.hs @@ -0,0 +1,50 @@ +module DDC.Core.Flow.Transform.Rates.Fail + ( Fail (..) + , LogFailures + , warn, run) +where +import DDC.Core.Flow.Prim +import DDC.Base.Pretty +import Control.Monad.Writer +import Data.List + + +-- | Why can't rates be inferred? +data Fail + -- | Function is not in a-normal form + = FailNotANormalForm + + -- | Bindings must be unique + | FailNamesNotUnique + + -- | Bindings must be named + | FailNoDeBruijnAllowed + + -- | Function contains letrec + | FailRecursiveBindings + + -- | Function contains letregion + | FailLetRegionNotHandled + + -- | The constraint would require a buffer. User must expicitly buffer. + | FailConstraintFilteredLessFiltered Name Name + + -- | The constraint would require a buffer. User must expicitly buffer. + | FailConstraintFilteredNotUnique Name Name + deriving (Show, Eq) + + +instance Pretty Fail where + ppr fails = text (show fails) + + +type LogFailures a = Writer [Fail] a + +warn :: Fail -> LogFailures () +warn w = tell [w] + +run :: LogFailures a -> (a, [Fail]) +run comp + = case runWriter comp of + (a, warns) -> (a, nub warns) + diff --git a/DDC/Core/Flow/Transform/Rates/Graph.hs b/DDC/Core/Flow/Transform/Rates/Graph.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Rates/Graph.hs @@ -0,0 +1,170 @@ +module DDC.Core.Flow.Transform.Rates.Graph + ( Graph + , Edge + , graphOfBinds + , graphTopoOrder + , mergeWeights + , traversal + , invertMap + , mlookup ) +where +import DDC.Core.Collect +import DDC.Core.Flow.Compounds +import DDC.Core.Flow.Prim +import DDC.Core.Flow.Exp +import qualified DDC.Type.Env as Env + +import Data.List (intersect, nub) +import qualified Data.Map as Map +import Data.Maybe (catMaybes) +import qualified Data.Set as Set + +-- | Graph for function +-- Each node is a binding, edges are dependencies, and the bool is whether the node's output +-- can be fused or contracted. +-- For example, filter and map dependencies can be contracted, +-- but a fold cannot as it must consume the entire stream before producing output. +-- + +type Edge = (Name, Bool) +type Graph = Map.Map Name [Edge] + +graphOfBinds :: [(Name,ExpF)] -> [Name] -> Graph +graphOfBinds binds extra_names + = Map.map mkEdges graph1 + where + mkEdges (refs, _fusible) + = map getFusible refs + + getFusible r + | Just (_,f) <- Map.lookup r graph1 + = (r, f) + | otherwise + = (r, True) + + graph1 + = Map.fromList + $ map gen + $ binds + + gen (k, xx) + = let free = catMaybes + $ map takeNameOfBound + $ Set.toList + $ freeX Env.empty xx + refs = free `intersect` names + in (k, (refs, fusible xx)) + + names = map fst binds ++ extra_names + + fusible xx + | Just (f, _) <- takeXApps xx + , XVar (UPrim (NameOpVector ov) _) <- f + = case ov of + OpVectorReduce + -> False + + -- Length of `concrete rate' is known before iteration, so should be contractible. + OpVectorLength + -> False + _ + -> True + + | otherwise + = True + + +-- | Find topological ordering of DAG +-- Does not check for cycles - really must be a DAG! +graphTopoOrder :: Graph -> [Name] +graphTopoOrder graph + = reverse $ go ([], Map.keysSet graph) + where + go (l, s) + = case Set.minView s of + Nothing + -> l + Just (m, _) + -> go (visit (l,s) m) + + visit (l,s) m + | Set.member m s + = let edges = mlookup "visit" graph m + pres = map fst edges + s' = Set.delete m s + (l',s'') = foldl visit (l,s') pres + in (m : l', s'') + + | otherwise + = (l,s) + + + +traversal :: Graph -> (Edge -> Name -> Int) -> Map.Map Name Int +traversal graph weight + = foldl go Map.empty + $ graphTopoOrder graph + where + go m node + = let pres = mlookup "traversal" graph node + + get e@(u,_) + | Just v <- Map.lookup u m + = v + weight e node + | otherwise + = 0 + + w = foldl max 0 + $ map get + $ pres + + in Map.insert node w m + + +mergeWeights :: Graph -> Map.Map Name Int -> Graph +mergeWeights graph weights + = foldl go Map.empty + $ graphTopoOrder graph + where + go m node + -- Merge if it's a weighted one + | Just k <- name_maybe node + = merge node k m + | otherwise + = merge node node m + + merge node k m + | Just edges <- Map.lookup node graph + = let edges' = nub $ map (\(n,f) -> (name n, f)) edges + in Map.insertWith (\x y -> nub $ x ++ y) k edges' m + | otherwise + = m + + weights' = invertMap weights + + name n + = maybe n id (name_maybe n) + + name_maybe n + | Just i <- Map.lookup n weights + , Just (v:_) <- Map.lookup i weights' + = Just v + | otherwise + = Nothing + + +invertMap :: (Ord k, Ord v) => Map.Map k v -> Map.Map v [k] +invertMap m + = Map.foldWithKey go Map.empty m + where + go k v m' = Map.insertWith (++) v [k] m' + + +mlookup :: Ord k => String -> Map.Map k v -> k -> v +mlookup str m k + | Just v <- Map.lookup k m + = v + | otherwise + = error ("ddc-core-flow.mlookup: no key " ++ str) + + diff --git a/DDC/Core/Flow/Transform/Rates/SeriesOfVector.hs b/DDC/Core/Flow/Transform/Rates/SeriesOfVector.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Rates/SeriesOfVector.hs @@ -0,0 +1,482 @@ +module DDC.Core.Flow.Transform.Rates.SeriesOfVector + (seriesOfVectorModule + ,seriesOfVectorFunction) +where +import DDC.Core.Collect +import DDC.Core.Flow.Compounds +import DDC.Core.Flow.Prim +import DDC.Core.Flow.Exp +import DDC.Core.Flow.Transform.Rates.Constraints +import DDC.Core.Flow.Transform.Rates.Fail +import DDC.Core.Flow.Transform.Rates.Graph +import DDC.Core.Module +import DDC.Core.Transform.Annotate +import DDC.Core.Transform.Deannotate +import qualified DDC.Type.Env as Env + +import Control.Applicative +import Control.Monad +import Data.List (intersect, nub) +import qualified Data.Map as Map +import Data.Maybe (catMaybes) +import qualified Data.Set as Set + +seriesOfVectorModule :: ModuleF -> (ModuleF, [(Name,Fail)]) +seriesOfVectorModule mm + = let body = deannotate (const Nothing) + $ moduleBody mm + + (lets, xx) = splitXLets body + letsErrs = map seriesOfVectorLets lets + + lets' = map fst letsErrs + errs = concatMap snd letsErrs + + body' = annotate () + $ xLets lets' xx + + + in -- trace ("ORIGINAL:"++ show (ppr $ moduleBody mm)) + -- trace ("MODULE:" ++ show (ppr body')) + (mm { moduleBody = body' }, errs) + + + +seriesOfVectorLets :: LetsF -> (LetsF, [(Name,Fail)]) +seriesOfVectorLets ll + | LLet b@(BName n _) x <- ll + , (x',errs) <- seriesOfVectorFunction x + = (LLet b x', map (\f -> (n,f)) errs) + + | LRec bxs <- ll + , (bs,xs) <- unzip bxs + , (xs',_errs) <- unzip $ map seriesOfVectorFunction xs + = (LRec (bs `zip` xs'), []) + -- We still need to produce errors if this doesn't work. + + | otherwise + = (ll, []) + + +-- | Takes a single function body. Function body must be in a-normal form. +seriesOfVectorFunction :: ExpF -> (ExpF, [Fail]) +seriesOfVectorFunction fun + = run $ do + -- Peel off the lambdas + let (lams, body) = takeXLamFlags_safe fun + + -- This assumes the body is already in a-normal form. + (lets, xx) = splitXLets body + + -- Split into name and values and warn for recursive bindings + binds <- takeLets lets + let tymap = takeTypes (concatMap valwitBindsOfLets lets ++ map snd lams) + + -- Assumes the binds only use vector primitives, + -- OR if not vector primitives, do not refer to bound vectors + + let names = map fst binds + -- Make sure names are unique + when (length names /= length (nub names)) $ + warn FailNamesNotUnique + + (constrs, equivs) + <- checkBindConstraints binds + + let extras = catMaybes + $ map (takeNameOfBind . snd) lams + let graph = graphOfBinds binds extras + + let rets = catMaybes + $ map takeNameOfBound + $ Set.toList + $ freeX Env.empty xx + + loops <- schedule graph equivs rets + + binds' <- orderBinds binds loops + + -- True <- trace ("TYMAP:" ++ show tymap) return True + -- True <- trace ("NAMES,LOOPS,NAMES':" ++ show (names, loops, map (map fst) binds')) + -- return True + + let outputs = map lOutputs loops + let inputs = map lInputs loops + + let getMax = getMaxSize constrs equivs extras + + return $ construct getMax lams (zip3 binds' outputs inputs) equivs tymap xx + +-- | Peel the lambdas off, or const if there are none +takeXLamFlags_safe x + | Just (binds, body) <- takeXLamFlags x + = (binds, body) + | otherwise + = ([], x) + + +-- | Split into name and values and warn for recursive bindings +takeLets :: [LetsF] -> LogFailures [(Name, ExpF)] +takeLets lets + = concat <$> mapM get lets + where + get (LLet (BName n _) x) = return [(n,x)] + get (LLet (BNone _) _) = return [] + get (LLet (BAnon _) _) = w FailNoDeBruijnAllowed + get (LRec _ ) = w FailRecursiveBindings + get (LPrivate _ _ _) = w FailLetRegionNotHandled + get (LWithRegion _ ) = w FailLetRegionNotHandled + + w err = warn err >> return [] + +-- | Split into name and values and warn for recursive bindings +takeTypes :: [Bind Name] -> Map.Map Name TypeF +takeTypes binds + = Map.fromList $ concatMap get binds + where + get (BName n t) = [(n,t)] + get _ = [] + + +data Loop + = Loop + { lBindings :: [Name] + , lOutputs :: [Name] + , lInputs :: [Name] + } deriving (Eq,Show) + +schedule :: Graph -> EquivClass -> [Name] -> LogFailures [Loop] +schedule graph equivs rets + = let type_order = map (canonName equivs . Set.findMin) equivs + -- minimumBy length $ map scheduleTypes $ permutations type_order + (wts, graph') = scheduleTypes graph equivs type_order + loops = scheduleAll (map snd wts) graph graph' + -- Use the original graph to find vars that cross loop boundaries + outputs = scheduleOutputs loops graph rets + inputs = scheduleInputs loops graph + in -- trace ("GRAPH,GRAPH',WTS,EQUIVS:" ++ show (graph, graph', wts, equivs)) + return $ zipWith3 Loop loops outputs inputs + +scheduleTypes :: Graph -> EquivClass -> [Name] -> ([(Name, Map.Map Name Int)], Graph) +scheduleTypes graph types type_order + = foldl go ([],graph) type_order + where + go (w,g) ty + = let w' = typedTraversal g types ty + g' = mergeWeights g w' + in ((ty,w') : w, g') + + +scheduleAll :: [Map.Map Name Int] -> Graph -> Graph -> [[Name]] +scheduleAll weights graph graph' + = loops + where + weights' = map invertMap weights + topo = graphTopoOrder graph' + loops = map getNames topo + + getNames n + = sort $ find n (weights `zip` weights') + + original_order = graphTopoOrder graph + + -- Cheesy hack to get ns in same order as the original graph's topo: + -- filter topo to only those elements in ns + sort ns + = filter (flip elem ns) original_order + + find _ [] + = [] + + find n ((w,w') : rest) + | Just i <- n `Map.lookup` w + , Just ns <- i `Map.lookup` w' + = ns + + | otherwise + = find n rest + +-- Find any variables that cross loop boundaries - they must be reified +scheduleOutputs :: [[Name]] -> Graph -> [Name] -> [[Name]] +scheduleOutputs loops graph rets + = map output loops + where + output ns + = graphOuts ns ++ filter (`elem` ns) rets + + graphOuts ns + = concatMap (\(k,es) -> if k `elem` ns + then [] + else ns `intersect` map fst es) + $ Map.toList graph + +-- Find any variables that cross loop boundaries - they must be reified +scheduleInputs :: [[Name]] -> Graph -> [[Name]] +scheduleInputs loops graph + = map input loops + where + input ns + = filter (\n -> not (n `elem` ns)) + $ graphIns ns + + graphIns ns + = nub $ concatMap (map fst . mlookup "graphIns" graph) ns + +typedTraversal :: Graph -> EquivClass -> Name -> Map.Map Name Int +typedTraversal graph types current_type + = restrictTypes types current_type + $ traversal graph w + where + w u v = if w' u v then 1 else 0 + + w' (u, fusible) v + | canonName types u == current_type + = canonName types v /= current_type || not fusible + + | otherwise + = False + + +restrictTypes :: EquivClass -> Name -> Map.Map Name Int -> Map.Map Name Int +restrictTypes types current_type weights + = Map.filterWithKey restrict weights + where + restrict n _ + = canonName types n == current_type + + +orderBinds :: [(Name,ExpF)] -> [Loop] -> LogFailures [[(Name,ExpF)]] +orderBinds binds loops + = let bindsM = Map.fromList binds + order = map lBindings loops + get k | Just v <- Map.lookup k bindsM + = [(k,v)] + | otherwise + = [] + in return $ map (\o -> concatMap get o) order + + +construct + :: (Name -> Name) + -> [(Bool, BindF)] + -> [([(Name, ExpF)], [Name], [Name])] + -> EquivClass + -> Map.Map Name TypeF + -> ExpF + -> ExpF +construct getMax lams loops equivs tys xx + = let lets = concatMap convert loops + in makeXLamFlags lams + $ xLets lets + $ xx + where + convert (binds, outputs, inputs) + = convertToSeries getMax binds outputs inputs equivs tys + + +-- We still need to join procs, +-- split output procs into separate functions +convertToSeries + :: (Name -> Name) -> [(Name,ExpF)] -> [Name] -> [Name] + -> EquivClass -> Map.Map Name TypeF -> [LetsF] + +convertToSeries getMax binds outputs inputs equivs tys + = concat setups + ++ [LLet (BNone tBool) (runprocs inputs' processes)] + ++ concat readrefs + where + runprocs :: [(Name,TypeF)] -> ExpF -> ExpF + runprocs vecs@((cn,_):_) body + = let cnn = canonName equivs cn + kN = NameVarMod cnn "k" + kFlags = [ (True, BName kN kRate) + , (False, BNone $ tRateNat $ TVar $ UName kN)] + vFlags = map (\(n,t) -> (False, BName (NameVarMod n "s") (tSeries (TVar (UName kN)) t))) + vecs + in xApps (xVarOpSeries (OpSeriesRunProcess $ length vecs)) + ( map (XType . snd) vecs + ++ map (XVar . UName . fst) vecs + ++ [(makeXLamFlags (kFlags ++ vFlags) body)]) + + -- Should we introduce a rate parameter for generates? + runprocs [] body + = body + + inputs' :: [(Name,TypeF)] + inputs' = concatMap filterInputs inputs + + filterInputs inp + | tyI <- mlookup "collectKloks" tys inp + , Just (_tcVec, [tyA]) <- takeTyConApps tyI + , tyI == tVector tyA + = [(inp, tyA)] + | otherwise + = [] + + processes + = foldr wrap joins binds + + wrap (n,x) body + = wrapSeriesX equivs outputs n (mlookup "wrap" tys n) x body + + joins + | not $ null outputs + = foldl1 mkJoin + $ map (\n -> XVar $ UName $ NameVarMod n "proc") outputs + | otherwise + = xUnit -- ??? + + mkJoin p q + = xApps (xVarOpSeries OpSeriesJoin) [p, q] + + -- fill vectors and read references + (setups, readrefs) + = unzip + $ map setread + $ filter (flip elem outputs . fst) binds + + setread (n,x) + = setreadSeriesX getMax tys n (mlookup "setread" tys n) x + + +setreadSeriesX + :: (Name -> Name) -> Map.Map Name TypeF -> Name -> TypeF -> ExpF -> ([LetsF], [LetsF]) +setreadSeriesX getMax tys name ty xx + | Just (f, args) <- takeXApps xx + , XVar (UPrim (NameOpVector ov) _) <- f + = case ov of + -- any folds MUST be known as outputs, so this is safe + OpVectorReduce + | [_tA, _f, z, _vA] <- args + -> ([ LLet (BName (nm "ref") (tRef ty)) (xNew ty z) ] + ,[ LLet (BName name ty) (xRead ty (vr $ nm "ref"))]) + + _ + | [_vec, tyR] <- takeTApps ty + , v <- getMax name -- canonName equivs name + , [_vec, tyCR] <- takeTApps $ mlookup "setreadSeriesX" tys v + -> let vl = xApps (xVarOpVector OpVectorLength) + [XType tyCR, XVar $ UName v] + in ([ LLet (BName name $ tBot kData) $ xNewVector tyR vl ] + , []) + + _ + -> ([], []) + | otherwise + = ([],[]) + where + nm s = NameVarMod name s + vr n = XVar $ UName n + + +wrapSeriesX :: EquivClass -> [Name] -> Name -> TypeF -> ExpF -> ExpF -> ExpF +wrapSeriesX equivs outputs name ty xx wrap + | Just (op, args) <- takeXApps xx + , XVar (UPrim (NameOpVector ov) _) <- op + = case ov of + OpVectorReduce + | [_tA, f, z, vA] <- args + , XVar (UName nvA) <- vA + , kA <- klok nvA + -> XLet (LLet (BName name'proc tProcess) + $ xApps (xVarOpSeries OpSeriesReduce) + [kA, XType ty, XVar (UName name'ref), f, z, modNameX "s" vA]) + wrap + + OpVectorMap n + | (tys, f : rest) <- splitAt (n+1) args + , length rest == n + , kT <- klok name + , rest' <- map (modNameX "s") rest + -> XLet (LLet (BName name's $ tBot kData) + $ xApps (xVarOpSeries (OpSeriesMap n)) + ([kT] ++ tys ++ [f] ++ rest')) + wrap'fill + + OpVectorFilter + | [tA, p, vA] <- args + , XVar (UName nvA) <- vA + , tkA <- klokT nvA + , kA <- klok nvA + , TVar (UName nkT) <- klokT name + , tkT <- klokT name + -> XLet (LLet (BName name'flags (tBot kData)) + $ xApps (xVarOpSeries (OpSeriesMap 1)) + ([kA, tA, XType tBool, p, modNameX "s" vA])) + $ xApps (xVarOpSeries (OpSeriesMkSel 1)) + ([kA, XVar (UName name'flags) + , XLAM (BName nkT kRate) + $ XLam (BName name'sel (tSel1 tkA tkT)) + $ XLet (LLet (BName name's (tBot kData)) + $ xApps (xVarOpSeries OpSeriesPack) + ([kA, XType tkT, tA, XVar (UName name'sel), modNameX "s" vA])) + wrap'fill ]) + + _ + -> xx + | otherwise + = xx + + where + name'flags= NameVarMod name "flags" + name'proc = NameVarMod name "proc" + name'ref = NameVarMod name "ref" + name's = NameVarMod name "s" + name'sel = NameVarMod name "sel" + + klokT n + = let n' = canonName equivs n + kN = NameVarMod n' "k" + in TVar $ UName kN + klok n + = XType $ klokT n + + tyR + | [_vec, tyR'] <- takeTApps ty + = Just tyR' + | otherwise + = Nothing + + wrap'fill + | name `elem` outputs + , Just tyR' <- tyR + = XLet (LLet (BName name'proc tProcess) $ xApps fillV [klok name, XType tyR', vr name, vr name's]) + wrap + | otherwise + = wrap + + fillV = xVarOpSeries OpSeriesFill + + vr n = XVar $ UName n + +-- tySeries +-- | Vector n + +xVarOpSeries n = XVar (UPrim (NameOpSeries n) (typeOpSeries n)) +xVarOpVector n = XVar (UPrim (NameOpVector n) (typeOpVector n)) + +modNameX :: String -> ExpF -> ExpF +modNameX s xx + = case xx of + XVar (UName n) + -> XVar (UName (NameVarMod n s)) + _ + -> xx + +{- + +\as,bs... +cs = map as +ds = filter as +n = fold ds +es = map3 bs cs +return es + +==> +schedule graph equivs [es] +==> + +[ [ds, n] +, [cs, es] ] + +-} diff --git a/DDC/Core/Flow/Transform/Schedule.hs b/DDC/Core/Flow/Transform/Schedule.hs --- a/DDC/Core/Flow/Transform/Schedule.hs +++ b/DDC/Core/Flow/Transform/Schedule.hs @@ -1,252 +1,13 @@ module DDC.Core.Flow.Transform.Schedule - (scheduleProcess) -where -import DDC.Core.Flow.Transform.Schedule.SeriesEnv -import DDC.Core.Flow.Transform.Schedule.Nest -import DDC.Core.Flow.Procedure -import DDC.Core.Flow.Process -import DDC.Core.Flow.Compounds -import DDC.Core.Flow.Prim -import DDC.Core.Flow.Exp -import DDC.Base.Pretty -import Control.Monad - - --- | Create loops from a list of operators. --- --- * The input series must all have the same rate. --- -scheduleProcess :: Process -> Procedure -scheduleProcess - (Process - { processName = name - , processParamTypes = psType - , processParamValues = psValue - , processContexts = contexts - , processOperators = ops - , processStmts = stmts - , processResultType = tResult - , processResult = xResult}) - = let - -- Create all the contexts, starting with an empty loop nest. - Just nest1 = foldM insertContext NestEmpty contexts - - -- Schedule the series operators into the nest. - nest2 = scheduleOperators nest1 emptySeriesEnv ops - - in Procedure - { procedureName = name - , procedureParamTypes = psType - , procedureParamValues = psValue - , procedureNest = nest2 - , procedureStmts = stmts - , procedureResultType = tResult - , procedureResult = xResult } - - -------------------------------------------------------------------------------- --- | Schedule some series operators into a loop nest. -scheduleOperators - :: Nest -- ^ The starting loop nest. - -> SeriesEnv -- ^ Series environment maps series binds to elem binds. - -> [Operator] -- ^ The operators to schedule. - -> Nest - -scheduleOperators nest0 env ops - = case ops of - [] -> nest0 - op : ops' - -> let (env', nest') = scheduleOperator nest0 env op - in scheduleOperators nest' env' ops' - - --- | Schedule a single series operator into a loop nest. -scheduleOperator - :: Nest -- ^ The current loop nest - -> SeriesEnv -- ^ Series environment maps series binds to elem binds. - -> Operator -- ^ Operator to schedule. - -> (SeriesEnv, Nest) - -scheduleOperator nest0 env op - - -- Id ------------------------------------------- - | OpId{} <- op - = let - -- Get binders for the input elements. - Just nSeries - = takeNameOfBound (opInputSeries op) - - (uInput, env1, nest1) - = bindNextElem nSeries - (opInputRate op) (opElemType op) - env nest0 - - Just bResultElem - = elemBindOfSeriesBind $ opResultSeries op - - context = ContextRate (opInputRate op) - - Just nest2 = insertBody nest1 context - $ [ BodyStmt bResultElem (XVar uInput) ] - - in (env1, nest2) - - - -- Create --------------------------------------- - | OpCreate{} <- op - = let - -- Get binders for the input elements. - Just nSeries - = takeNameOfBound (opInputSeries op) - - (uInput, env1, nest1) - = bindNextElem nSeries - (opInputRate op) (opElemType op) - env nest0 - - -- Insert statements that allocate the vector. - -- We use the type-level series rate to describe the length of - -- the vector. This will be repalced by a RateNat value during - -- the concretization phase. - BName nVec _ = opResultVector op - context = ContextRate (opInputRate op) - - -- Rate we're using to allocate the result vector. - -- This will be larger than the actual result series rate if we're - -- creating a vector inside a selector context. - Just tRateAlloc = opAllocRate op - - Just nest2 = insertStarts nest1 context - $ [ StartVecNew - nVec -- allocated vector - (opElemType op) -- elem type - tRateAlloc ] -- allocation rate - - -- Insert statements that write the current element to the vector. - Just nest3 = insertBody nest2 context - $ [ BodyVecWrite - nVec -- destination vector - (opElemType op) -- elem type - (XVar (UIx 0)) -- index - (XVar uInput) ] -- value - - -- Slice the vector at the end - Just nest4 = insertEnds nest3 context - $ [ EndVecSlice - nVec -- destination vector - (opElemType op) -- elem type - (opInputRate op) ] -- index - - -- But only slice it if the input rate is different to output rate - nest' = if opInputRate op == tRateAlloc - then nest3 - else nest4 - in (env1, nest') - - - -- Maps ----------------------------------------- - | OpMap{} <- op - = let - -- Get binders for the input elements. - Just nsSeries = sequence $ map takeNameOfBound $ opInputSeriess op - tsRate = repeat (opInputRate op) - tsElem = map typeOfBind $ opWorkerParams op - - (usInputs, env1, nest1) - = bindNextElems (zip3 nsSeries tsRate tsElem) env nest0 - - -- Variables for all the input elements. - xsInputs = map XVar usInputs - - -- Substitute input element vars into the worker body. - xBody = foldl (\x (b, p) -> XApp (XLam b x) p) - (opWorkerBody op) - (zip (opWorkerParams op) xsInputs) - - -- Binder for a single result element in the series context. - Just nResultSeries = takeNameOfBind $ opResultSeries op - nResultElem = NameVarMod nResultSeries "elem" - uResultElem = UName nResultElem - - Just bResultElem = elemBindOfSeriesBind (opResultSeries op) - - -- Insert the expression that computes the new result into the nest. - context = ContextRate $ opInputRate op - Just nest2 = insertBody nest1 context - $ [ BodyStmt bResultElem xBody ] - - -- Associate the variable for the result element with the result series. - env2 = insertElemForSeries nResultSeries uResultElem env1 - - in (env2, nest2) - - - -- Folds --------------------------------------- - | OpFold{} <- op - = let - -- Lookup binders for the input elements. - Just nSeries = takeNameOfBound (opInputSeries op) - tRate = opInputRate op - tInputElem = typeOfBind (opWorkerParamElem op) - (uInput, env1, nest1) - = bindNextElem nSeries tRate tInputElem env nest0 - - -- Make a name for the accumulator. - BName nResult _ = opResultValue op - nAcc = NameVarMod nResult "acc" - - -- Type of the accumulator. - tAcc = typeOfBind (opWorkerParamAcc op) - - -- Insert statements that initialize the starting value - -- of the accumulator. - context = ContextRate $ opInputRate op - Just nest2 = insertStarts nest1 context - $ [ StartAcc nAcc tAcc (opZero op) ] - - -- Substitute input and accumulator vars into worker body. - xBody = XApp (XApp ( XLam (opWorkerParamElem op) - $ XLam (opWorkerParamIndex op) - (opWorkerBody op)) - (XVar uInput)) - (XVar (UIx 0)) - - -- Insert statements that update the accumulator - -- into the loop body. - Just nest3 = insertBody nest2 context - $ [ BodyAccRead nAcc tAcc (opWorkerParamAcc op) - , BodyAccWrite nAcc tAcc xBody ] - - -- Insert statements that read back the final value - -- after the loop has finished. - Just nest4 = insertEnds nest3 context - $ [ EndAcc nResult tAcc nAcc ] - in (env1, nest4) - - - -- Pack ---------------------------------------- - | OpPack{} <- op - = let - -- Lookup binder for the input element. - Just nSeries = takeNameOfBound (opInputSeries op) - tRate = opInputRate op - tInputElem = opElemType op - (uInput, env1, nest1) - = bindNextElem nSeries tRate tInputElem env nest0 - - -- Associate the variable for the result element with the result - -- series. We could instead add an explicit binding, but it's - -- easier just to insert an entry into the series environment. - Just nResultSeries = takeNameOfBind (opResultSeries op) - env2 = insertElemForSeries nResultSeries uInput env1 - - in (env2, nest1) + ( scheduleScalar - | otherwise - = error $ renderIndent - $ vcat [ text "ddc-core-flow.scheduleOperator" - , indent 4 $ text "Can't schedule operator." - , indent 4 $ ppr op ] + -- * Scheduling process kernels + , scheduleKernel + , Error (..) + , Lifting (..)) +where +import DDC.Core.Flow.Transform.Schedule.Kernel +import DDC.Core.Flow.Transform.Schedule.Scalar diff --git a/DDC/Core/Flow/Transform/Schedule/Base.hs b/DDC/Core/Flow/Transform/Schedule/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Schedule/Base.hs @@ -0,0 +1,86 @@ + +module DDC.Core.Flow.Transform.Schedule.Base + ( elemBindOfSeriesBind + , elemBoundOfSeriesBound + , elemTypeOfSeriesType + , rateTypeOfSeriesType + , slurpRateOfParamTypes + + , elemTypeOfVectorType) +where +import DDC.Core.Flow.Transform.Schedule.Error +import DDC.Core.Flow.Compounds +import DDC.Core.Flow.Prim +import DDC.Core.Flow.Exp +import Data.Maybe + + +-- | Given the bind of a series, produce the bound that refers to the +-- next element of the series in its context. +elemBindOfSeriesBind :: BindF -> Maybe BindF +elemBindOfSeriesBind bSeries + | BName nSeries tSeries' <- bSeries + , nElem <- NameVarMod nSeries "elem" + , Just tElem <- elemTypeOfSeriesType tSeries' + = Just $ BName nElem tElem + + | otherwise + = Nothing + + +-- | Given the bound of a series, produce the bound that refers to the +-- next element of the series in its context. +elemBoundOfSeriesBound :: BoundF -> Maybe BoundF +elemBoundOfSeriesBound uSeries + | UName nSeries <- uSeries + , nElem <- NameVarMod nSeries "elem" + = Just $ UName nElem + + | otherwise + = Nothing + + +-- | Given the type of a series like @Series k e@, produce the type +-- of a single element, namely the @e@. +elemTypeOfSeriesType :: TypeF -> Maybe TypeF +elemTypeOfSeriesType tSeries' + | Just (_tcSeries, [_tK, tE]) <- takeTyConApps tSeries' + = Just tE + + | otherwise + = Nothing + + +-- | Given the type of a series like @Series k e@, produce the type +-- of the rate, namely the @k@. +rateTypeOfSeriesType :: TypeF -> Maybe TypeF +rateTypeOfSeriesType tSeries' + | Just (_tcSeries, [tK, _tE]) <- takeTyConApps tSeries' + = Just tK + + | otherwise + = Nothing + + +-- | Given the type of the process parameters, +-- yield the rate of the overall process. +slurpRateOfParamTypes :: [Type Name] -> Either Error (Type Name) +slurpRateOfParamTypes tsParam + = case mapMaybe rateTypeOfSeriesType tsParam of + [] -> Left ErrorNoSeriesParameters + [tK] -> Right tK + (tK : ts) + | all (== tK) ts -> Right tK + | otherwise -> Left ErrorMultipleRates + + +-- Vector --------------------------------------------------------------------- +-- | Given the type of a vector like @Vector k e@, produce the type +-- of a single element, namely the @e@. +elemTypeOfVectorType :: TypeF -> Maybe TypeF +elemTypeOfVectorType tVector' + | Just (_tcVector, [tE]) <- takeTyConApps tVector' + = Just tE + + | otherwise + = Nothing diff --git a/DDC/Core/Flow/Transform/Schedule/Error.hs b/DDC/Core/Flow/Transform/Schedule/Error.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Schedule/Error.hs @@ -0,0 +1,76 @@ + +module DDC.Core.Flow.Transform.Schedule.Error + (Error (..)) +where +import DDC.Core.Flow.Exp +import DDC.Core.Flow.Prim +import DDC.Core.Flow.Process.Operator +import DDC.Core.Transform.Annotate +import DDC.Core.Pretty +import qualified DDC.Core.Flow.Transform.Slurp.Error as Slurp + + +-- | Reason a process kernel could not be scheduled into a procedure. +data Error + -- | Process has no rate parameters. + = ErrorNoRateParameters + + -- | Process has no series parameters, + -- but there needs to be at least one. + | ErrorNoSeriesParameters + + -- | Process has series of different rates, + -- but all series must have the same rate. + | ErrorMultipleRates + + -- | Primary rate variable of the process does not match + -- the rate of the paramter series. + | ErrorPrimaryRateMismatch + + -- | Cannot lift expression to vector operators. + | ErrorCannotLiftExp (Exp () Name) + + -- | Cannot lift type to vector type. + | ErrorCannotLiftType (Type Name) + + -- | Current scheduler does not support this operator. + | ErrorUnsupported Operator + + -- | Cannot slurp process description from one of the top-level + -- declarations. + | ErrorSlurpError Slurp.Error + deriving Show + + +instance Pretty Error where + ppr err + = case err of + ErrorNoRateParameters + -> vcat [ text "Series process has no rate parameters." ] + + ErrorNoSeriesParameters + -> vcat [ text "Series process has no series parameters."] + + ErrorMultipleRates + -> vcat [ text "Series process has multiple rate parameters."] + + ErrorPrimaryRateMismatch + -> vcat [ text "Series process primary rate mismatch."] + + ErrorCannotLiftExp x + -> vcat [ text "Cannot lift expression in series process." + , empty + , indent 4 $ ppr (annotate () x) ] + + ErrorCannotLiftType t + -> vcat [ text "Cannot lift type in series process." + , empty + , indent 4 $ ppr t ] + + ErrorUnsupported _ + -> vcat [ text "Cannot lower series operator with this method."] + + ErrorSlurpError errSlurp + -> vcat [ text "Error slurping series process." + , indent 2 $ ppr errSlurp ] + diff --git a/DDC/Core/Flow/Transform/Schedule/Kernel.hs b/DDC/Core/Flow/Transform/Schedule/Kernel.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Schedule/Kernel.hs @@ -0,0 +1,330 @@ + +module DDC.Core.Flow.Transform.Schedule.Kernel + ( scheduleKernel + , Error (..) + , Lifting (..)) +where +import DDC.Core.Flow.Transform.Schedule.Nest +import DDC.Core.Flow.Transform.Schedule.Error +import DDC.Core.Flow.Transform.Schedule.Lifting +import DDC.Core.Flow.Transform.Schedule.Base +import DDC.Core.Flow.Process +import DDC.Core.Flow.Procedure +import DDC.Core.Flow.Compounds +import DDC.Core.Flow.Exp +import DDC.Core.Flow.Prim +import Control.Monad +import Data.Maybe + + +-- | Schedule a process kernel into a procedure. +-- +-- A process kernel is a process with the following restricitions: +-- 1) All input series have the same rate. +-- 2) A kernel accumulates data into sinks, rather than allocating new values. +-- 3) A kernel can be scheduled into a single loop. +-- +--- The process kernel scheduler can produce code for +-- map, reduce, fill, gather, scatter +-- +-- But not +-- fold -- use reduce instead. +-- create -- use fill instead. +-- pack -- we don't support SIMD masks. +-- +scheduleKernel :: Lifting -> Process -> Either Error Procedure +scheduleKernel + lifting + (Process { processName = name + , processParamTypes = bsParamTypes + , processParamValues = bsParamValues + , processOperators = operators }) + = do + -- Check the parameter series all have the same rate. + tK <- slurpRateOfParamTypes (map typeOfBind bsParamValues) + + -- Check the primary rate variable matches the rates of the series. + (case bsParamTypes of + [] -> Left ErrorNoRateParameters + BName n k : _ + | k == kRate + , TVar (UName n) == tK -> return () + _ -> Left ErrorPrimaryRateMismatch) + + -- Lower rates of series parameters. + let bsParamValues_lowered + = map (\(BName n t) + -> let t' = fromMaybe t $ lowerSeriesRate lifting t + in BName n t') + $ bsParamValues + + -- Create the initial loop nest of the process rate. + let bsSeries = [ b | b <- bsParamValues + , isSeriesType (typeOfBind b) ] + + -- Body expressions that take the next vec of elements from each + -- input series. If the type can't be lifted this will just throw + -- a pattern match error. + let c = liftingFactor lifting + let ssBody = [ BodyStmt + (BName (NameVarMod nS "elem") tElem_lifted) + (xNextC c tK tElem (XVar (UName nS)) (XVar uIndex)) + | BName nS tS <- bsSeries + , let Just tElem = elemTypeOfSeriesType tS + , let uIndex = UIx 0 + , let Just tElem_lifted = liftType lifting tElem ] + + let nest0 = NestLoop + { nestRate = tDown c tK + , nestStart = [] + , nestBody = ssBody + , nestInner = NestEmpty + , nestEnd = [] + , nestResult = xUnit } + + nest' <- foldM (scheduleOperator lifting bsParamValues) + nest0 operators + + return $ Procedure + { procedureName = name + , procedureParamTypes = bsParamTypes + , procedureParamValues = bsParamValues_lowered + , procedureNest = nest' } + + +------------------------------------------------------------------------------- +-- | Schedule a single series operator into a loop nest. +scheduleOperator + :: Lifting + -> ScalarEnv + -> Nest -- ^ The current loop nest. + -> Operator -- ^ The operator to schedule. + -> Either Error Nest + +scheduleOperator lifting envScalar nest op + -- Map ----------------------------------------- + | OpMap{} <- op + = do let c = liftingFactor lifting + let tK = opInputRate op + let tK_down = tDown c tK + + -- Bind for the result element. + let Just bResultE = elemBindOfSeriesBind (opResultSeries op) + >>= liftTypeOfBind lifting + + -- Bounds for all the input series. + let Just usInput = sequence + $ map elemBoundOfSeriesBound + $ opInputSeriess op + + -- Bounds for the worker parameters, along with the lifted versions. + let bsParam = opWorkerParams op + bsParam_lifted <- mapM (liftTypeOfBindM lifting) bsParam + let envLift = zip bsParam bsParam_lifted + + xWorker_lifted <- liftWorker lifting envScalar envLift + $ opWorkerBody op + + -- Expression to apply the inputs to the worker. + let xBody = foldl (\x (b, p) -> XApp (XLam b x) p) + (xWorker_lifted) + [(b, XVar u) + | b <- bsParam_lifted + | u <- usInput ] + + let Just nest2 = insertBody nest tK_down + $ [ BodyStmt bResultE xBody ] + + return nest2 + + -- Fill ---------------------------------------- + | OpFill{} <- op + = do let c = liftingFactor lifting + let tK = opInputRate op + let tK_down = tDown c tK + + -- Bound for input element. + let Just uInput = elemBoundOfSeriesBound + $ opInputSeries op + + -- Write to target vector. + let Just nest2 = insertBody nest tK_down + $ [ BodyStmt (BNone tUnit) + (xWriteVectorC c + (opElemType op) + (XVar $ opTargetVector op) + (XVar $ UIx 0) + (XVar $ uInput)) ] + + -- Bind final unit value. + let Just nest3 = insertEnds nest2 tK_down + $ [ EndStmt (opResultBind op) + xUnit ] + + return nest3 + + -- Reduce -------------------------------------- + | OpReduce{} <- op + = do let c = liftingFactor lifting + let tK = opInputRate op + let tK_down = tDown c tK + let tA = typeOfBind $ opWorkerParamElem op + + -- Evaluate the zero value and initialize the vector accumulator. + let UName nRef = opTargetRef op + let nAccZero = NameVarMod nRef "zero" + let bAccZero = BName nAccZero tA + let uAccZero = UName nAccZero + + let nAccVec = NameVarMod nRef "vec" + let uAccVec = UName nAccVec + + let Just nest2 + = insertStarts nest tK_down + $ [ StartStmt bAccZero (opZero op) + , StartAcc nAccVec + (tVec c tA) + (xvRep c tA (XVar uAccZero)) ] + + -- Bound for input element. + let Just uInput = elemBoundOfSeriesBound + $ opInputSeries op + + -- Bound for intermediate accumulator value. + let nAccVal = NameVarMod nRef "val" + let uAccVal = UName nAccVal + let bAccVal = BName nAccVal (tVec c tA) + + -- Lift the worker function. + let bsParam = [ opWorkerParamAcc op, opWorkerParamElem op ] + bsParam_lifted <- mapM (liftTypeOfBindM lifting) bsParam + let envLift = zip bsParam bsParam_lifted + + xWorker_lifted <- liftWorker lifting envScalar envLift + $ opWorkerBody op + + -- Read the current accumulator value and update it with the worker. + let xBody_lifted x1 x2 + = XApp (XApp ( XLam (opWorkerParamAcc op) + $ XLam (opWorkerParamElem op) + (xWorker_lifted)) + x1) + x2 + + let Just nest3 + = insertBody nest2 tK_down + $ [ BodyAccRead nAccVec (tVec c tA) bAccVal + , BodyAccWrite nAccVec (tVec c tA) + (xBody_lifted (XVar uAccVal) (XVar uInput)) ] + + -- Read back the vector accumulator and to a final fold over its parts. + let nAccResult = NameVarMod nRef "res" + let bAccResult = BName nAccResult (tVec c tA) + let uAccResult = UName nAccResult + let bPart (i :: Int) = BName (NameVarMod nAccResult (show i)) tA + let uPart (i :: Int) = UName (NameVarMod nAccResult (show i)) + + let nAccInit = NameVarMod nRef "init" + + let xBody x1 x2 + = XApp (XApp ( XLam (opWorkerParamAcc op) + $ XLam (opWorkerParamElem op) + (opWorkerBody op)) + x1) + x2 + + let Just nest4 + = insertEnds nest3 tK_down + $ [ EndStmt bAccResult + (xRead (tVec c tA) (XVar uAccVec)) + + , EndStmt (BName nAccInit tA) + (xRead tA (XVar $ opTargetRef op)) ] + + ++ [ EndStmt (bPart 0) + (xBody (XVar $ UName nAccInit) + (xvProj c 0 tA (XVar uAccResult))) ] + + ++ [ EndStmt (bPart i) + (xBody (XVar (uPart (i - 1))) + (xvProj c i tA (XVar uAccResult))) + | i <- [1.. c - 1]] + + -- Write final value to destination. + let Just nest5 = insertEnds nest4 tK_down + $ [ EndStmt (BNone tUnit) + (xWrite tA (XVar $ opTargetRef op) + (XVar $ uPart (c - 1))) ] + -- Bind final unit value. + let Just nest6 + = insertEnds nest5 tK_down + $ [ EndStmt (opResultBind op) + xUnit ] + + + return $ nest6 + + + -- Gather -------------------------------------- + | OpGather{} <- op + = do + let c = liftingFactor lifting + let tK = opInputRate op + let tK_down = tDown c tK + + -- Bind for result element. + let Just bResultE = elemBindOfSeriesBind (opResultBind op) + >>= liftTypeOfBind lifting + + -- Bound of source index. + let Just uIndex = elemBoundOfSeriesBound (opSourceIndices op) + + -- Read from vector. + let Just nest2 = insertBody nest tK_down + $ [ BodyStmt bResultE + (xvGather c + (opElemType op) + (XVar $ opSourceVector op) + (XVar $ uIndex)) ] + + return nest2 + + -- Scatter ------------------------------------- + | OpScatter{} <- op + = do + let c = liftingFactor lifting + let tK = opInputRate op + let tK_down = tDown c tK + + -- Bound of source index. + let Just uIndex = elemBoundOfSeriesBound (opSourceIndices op) + + -- Bound of source elements. + let Just uElem = elemBoundOfSeriesBound (opSourceElems op) + + -- Read from vector. + let Just nest2 = insertBody nest tK_down + $ [ BodyStmt (BNone tUnit) + (xvScatter c + (opElemType op) + (XVar $ opTargetVector op) + (XVar $ uIndex) (XVar $ uElem)) ] + + -- Bind final unit value. + let Just nest3 = insertEnds nest2 tK_down + $ [ EndStmt (opResultBind op) + xUnit ] + + return nest3 + + -- Unsupported --------------------------------- + | otherwise + = Left $ ErrorUnsupported op + + +liftTypeOfBindM :: Lifting -> Bind Name -> Either Error (Bind Name) +liftTypeOfBindM lifting b + = case liftTypeOfBind lifting b of + Just b' -> return b' + _ -> Left $ ErrorCannotLiftType (typeOfBind b) + diff --git a/DDC/Core/Flow/Transform/Schedule/Lifting.hs b/DDC/Core/Flow/Transform/Schedule/Lifting.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Schedule/Lifting.hs @@ -0,0 +1,129 @@ + +module DDC.Core.Flow.Transform.Schedule.Lifting + ( Lifting (..) + , ScalarEnv + , LiftEnv + + -- * Lifting Types + , liftType + , liftTypeOfBind + , liftWorker + + -- * Lowering Types + , lowerSeriesRate) +where +import DDC.Core.Flow.Transform.Schedule.Error +import DDC.Core.Flow.Compounds +import DDC.Core.Flow.Exp +import DDC.Core.Flow.Prim +import Control.Monad +import Data.List + + +-- | Lifting config controls how many elements should be processed +-- per loop iteration. +data Lifting + = Lifting + { -- How many elements to process for each loop iteration. + liftingFactor :: Int } + deriving (Eq, Show) + + +-- | Scalar values in scope. +type ScalarEnv + = [BindF] + +-- | Map original variable to lifted version. +type LiftEnv + = [(BindF, BindF)] + + +-- | Try to lift the given type. +liftType :: Lifting -> TypeF -> Maybe TypeF +liftType l tt + | liftingFactor l == 1 + = Just tt + + | elem tt + [ tFloat 32, tFloat 64 + , tWord 8, tWord 16, tWord 32, tWord 64 + , tInt + , tNat ] + + = Just (tVec (liftingFactor l) tt) + + | otherwise + = Nothing + + +-- | Try to lift the type of a binder. +liftTypeOfBind :: Lifting -> BindF -> Maybe BindF +liftTypeOfBind l b + = case b of + BName n t -> liftM (BName n) (liftType l t) + BAnon t -> liftM BAnon (liftType l t) + BNone t -> liftM BNone (liftType l t) + + +-- | Try to lift a first-order worker expression to so it operates on elements +-- of vec type instead of scalars. +liftWorker :: Lifting -> ScalarEnv -> LiftEnv -> ExpF -> Either Error ExpF +liftWorker lifting envScalar envLift xx + = let down = liftWorker lifting envScalar envLift + in case xx of + XVar u + -- Replace vars by their vector version. + | Just (_, bL) <- find (\(bS', _) -> boundMatchesBind u bS') envLift + , Just uL <- takeSubstBoundOfBind bL + -> Right (XVar uL) + + -- Replicate scalar vars. + -- ISSUE #328: Element type for rep opretora is hard coded to Float32 + | any (boundMatchesBind u) envScalar + , nPrim <- PrimVecRep (liftingFactor lifting) + , tPrim <- typePrimVec nPrim + -> Right $ XApp (XApp (XVar (UPrim (NamePrimVec nPrim) tPrim)) + (XType $ tFloat 32)) + xx + + -- Replicate literals. + -- ISSUE #328: Element type for rep opretora is hard coded to Float32 + XCon dc + | DaConPrim (NameLitFloat _ 32) _ + <- dc + , nPrim <- PrimVecRep (liftingFactor lifting) + , tPrim <- typePrimVec nPrim + -> Right $ XApp (XApp (XVar (UPrim (NamePrimVec nPrim) tPrim)) + (XType $ tFloat 32)) + xx + + -- Replace scalar primops by vector versions. + XApp (XVar (UPrim (NamePrimArith prim) _)) (XType tElem) + | Just prim' <- liftPrimArithToVec (liftingFactor lifting) prim + -> Right $ XApp (XVar (UPrim (NamePrimVec prim') (typePrimVec prim'))) + (XType tElem) + + + -- Boiler plate application. + XApp x1 x2 + -> do x1' <- down x1 + x2' <- down x2 + return $ XApp x1' x2' + + + _ -> Left (ErrorCannotLiftExp xx) + + +-- Down ----------------------------------------------------------------------- +-- | Lower the rate of a series, +-- to account for lifting of the code that consumes it. +lowerSeriesRate :: Lifting -> TypeF -> Maybe TypeF +lowerSeriesRate lifting tt + | Just (NameTyConFlow TyConFlowSeries, [tK, tA]) + <- takePrimTyConApps tt + , c <- liftingFactor lifting + = Just (tSeries (tDown c tK) tA) + + | otherwise + = Nothing + diff --git a/DDC/Core/Flow/Transform/Schedule/Nest.hs b/DDC/Core/Flow/Transform/Schedule/Nest.hs --- a/DDC/Core/Flow/Transform/Schedule/Nest.hs +++ b/DDC/Core/Flow/Transform/Schedule/Nest.hs @@ -1,9 +1,14 @@ module DDC.Core.Flow.Transform.Schedule.Nest - ( insertContext + ( -- * Insertion into a loop nest + insertContext , insertStarts , insertBody - , insertEnds) + , insertEnds + + -- * Rate predicates + , nestContainsRate + , nestContainsGuardedRate) where import DDC.Core.Flow.Procedure import DDC.Core.Flow.Compounds @@ -16,59 +21,136 @@ -- | Insert a skeleton context into a nest. -- The new context doesn't contain any statements, it just provides -- the infrastructure to execute statements at the new rate. +-- insertContext :: Nest -> Context -> Maybe Nest +-- Context already exists, don't bother. +insertContext nest context@ContextRate{} + | nestContainsRate nest (contextRate context) + = Just nest + -- Loop context at top level. insertContext NestEmpty context@ContextRate{} = Just $ nestOfContext context --- Selector context inside loop context. + +-- Drop Selector Context ------------------------ +-- Selector context goes at this level in the loop nest. insertContext nest@NestLoop{} context@ContextSelect{} | nestRate nest == contextOuterRate context + , Just starts <- startsForContext context = Just $ nest { nestInner = nestInner nest <> nestOfContext context - , nestStart = nestStart nest ++ startsForSelect context } + , nestStart = nestStart nest ++ starts } --- Selector context needs to be inserted deeper in this nest. +-- Selector context need to be inserted deeper in the nest. insertContext nest@NestLoop{} context@ContextSelect{} | nestContainsRate nest (contextOuterRate context) , Just inner' <- insertContext (nestInner nest) context + , Just starts <- startsForContext context = Just $ nest { nestInner = inner' - , nestStart = nestStart nest ++ startsForSelect context } + , nestStart = nestStart nest ++ starts } --- Nested selector context inside selector context. -insertContext nest@NestIf{} context@ContextSelect{} +-- Selector context inserted inside an existing selector context. +insertContext nest@NestGuard{} context@ContextSelect{} | nestInnerRate nest == contextOuterRate context = Just $ nest { nestInner = nestInner nest <> nestOfContext context } +-- Drop Segment Context ------------------------- +-- Selector context goes at this level in the loop nest. +insertContext nest@NestLoop{} context@ContextSegment{} + | nestRate nest == contextOuterRate context + , Just starts <- startsForContext context + = Just $ nest + { nestInner = nestInner nest <> nestOfContext context + , nestStart = nestStart nest ++ starts } + insertContext _nest _context = Nothing --- | Yield a skeleton nest for a given context. -nestOfContext :: Context -> Nest -nestOfContext context - = case context of - ContextRate tRate - -> NestLoop - { nestRate = tRate - , nestStart = [] - , nestBody = [] - , nestInner = NestEmpty - , nestEnd = [] - , nestResult = xUnit } +------------------------------------------------------------------------------- +-- | Insert starting statements in the given context. +insertStarts :: Nest -> TypeF -> [StmtStart] -> Maybe Nest +insertStarts nest tRate starts' + = case nest of + NestLoop{} + -- Desired context is right here. + | tRate == nestRate nest + -> Just $ nest { nestStart = nestStart nest ++ starts' } - ContextSelect{} - -> NestIf - { nestOuterRate = contextOuterRate context - , nestInnerRate = contextInnerRate context - , nestFlags = contextFlags context - , nestBody = [] - , nestInner = NestEmpty } + -- Desired context is deeper in the nest. + -- The starting statements run before all interations of it. + | nestContainsRate nest tRate + -> Just $ nest { nestStart = nestStart nest ++ starts' } + _ -> Nothing + +------------------------------------------------------------------------------- +-- | Insert starting statements in the given context. +insertBody :: Nest -> TypeF -> [StmtBody] -> Maybe Nest +insertBody nest tRate body' + = case nest of + NestLoop{} + -- Desired context is right here. + | tRate == nestRate nest + -> Just $ nest { nestBody = nestBody nest ++ body' } + + -- Desired context is deeper in the nest. + | Just inner' <- insertBody (nestInner nest) tRate body' + -> Just $ nest { nestInner = inner' } + + NestGuard{} + -- Desired context is right here. + | tRate == nestInnerRate nest + -> Just $ nest { nestBody = nestBody nest ++ body' } + + -- Desired context is deeper in the nest. + | Just inner' <- insertBody (nestInner nest) tRate body' + -> Just $ nest { nestInner = inner' } + + NestSegment{} + -- Desired context is right here. + | tRate == nestInnerRate nest + -> Just $ nest { nestBody = nestBody nest ++ body' } + + -- Desired context is deeper in the nest. + | Just inner' <- insertBody (nestInner nest) tRate body' + -> Just $ nest { nestInner = inner' } + + NestList (n : ns) + | Just n' <- insertBody n tRate body' + -> Just $ NestList (n':ns) + + | Just (NestList ns') <- insertBody (NestList ns) tRate body' + -> Just $ NestList (n:ns') + + + _ -> Nothing + + +------------------------------------------------------------------------------- +-- | Insert ending statements in the given context. +insertEnds :: Nest -> TypeF -> [StmtEnd] -> Maybe Nest +insertEnds nest tRate ends' + = case nest of + NestLoop{} + -- Desired context is right here. + | tRate == nestRate nest + -> Just $ nest { nestEnd = nestEnd nest ++ ends' } + + -- Desired context is deeper in the nest. + -- The ending statements run before all iterations of it. + | nestContainsRate nest tRate + -> Just $ nest { nestEnd = nestEnd nest ++ ends' } + + _ -> Nothing + + +-- Rate Predicates ------------------------------------------------------------ -- | Check whether the top-level of this nest contains the given rate. -- It might be in a nested context. nestContainsRate :: Nest -> TypeF -> Bool @@ -84,94 +166,88 @@ -> nestRate nest == tRate || nestContainsRate (nestInner nest) tRate - NestIf{} + NestGuard{} -> nestInnerRate nest == tRate || nestContainsRate (nestInner nest) tRate + NestSegment{} + -> nestInnerRate nest == tRate + || nestContainsRate (nestInner nest) tRate --- | For a select context make statements that initialise the counter of --- how many times the inner context has been entered. -startsForSelect :: Context -> [StmtStart] -startsForSelect context - = let ContextSelect{} = context - TVar (UName nK) = contextInnerRate context - nCounter = NameVarMod nK "count" - in [StartAcc - { startAccName = nCounter - , startAccType = tNat - , startAccExp = xNat 0 }] +-- | Check whether the given rate is the inner rate of some +-- `NestGuard` constructor. +nestContainsGuardedRate :: Nest -> TypeF -> Bool +nestContainsGuardedRate nest tRate + = case nest of + NestEmpty + -> False -------------------------------------------------------------------------------- --- | Insert starting statements in the given context. -insertStarts :: Nest -> Context -> [StmtStart] -> Maybe Nest + NestList ns + -> any (flip nestContainsRate tRate) ns --- The starts are for this loop. -insertStarts nest@NestLoop{} (ContextRate tRate) starts' - | tRate == nestRate nest - = Just $ nest { nestStart = nestStart nest ++ starts' } + NestLoop{} + -> nestContainsGuardedRate (nestInner nest) tRate --- The starts are for some inner context contained by this loop, --- so we can still drop them here. -insertStarts nest@NestLoop{} (ContextRate tRate) starts' - | nestContainsRate nest tRate - = Just $ nest { nestStart = nestStart nest ++ starts' } + NestGuard{} + -> nestInnerRate nest == tRate + || nestContainsGuardedRate (nestInner nest) tRate -insertStarts _ _ _ - = Nothing + NestSegment{} + -> nestContainsGuardedRate (nestInner nest) tRate -------------------------------------------------------------------------------- --- | Insert starting statements in the given context. -insertBody :: Nest -> Context -> [StmtBody] -> Maybe Nest - -insertBody nest@NestLoop{} context@(ContextRate tRate) body' - -- If the desired context is the same as the loop then we can drop - -- the statements right here. - | tRate == nestRate nest - = Just $ nest { nestBody = nestBody nest ++ body' } - - -- Try and insert them in an inner context. - | Just inner' <- insertBody (nestInner nest) context body' - = Just $ nest { nestInner = inner' } - -insertBody nest@NestIf{} context@(ContextRate tRate) body' - | tRate == nestInnerRate nest - = Just $ nest { nestBody = nestBody nest ++ body' } - - | Just inner' <- insertBody (nestInner nest) context body' - = Just $ nest { nestInner = inner' } - -insertBody (NestList (n:ns)) context body' - | Just n' <- insertBody n context body' - = Just $ NestList (n':ns) +-- Skeleton nests ------------------------------------------------------------- +-- | Yield a skeleton nest for a given context. +nestOfContext :: Context -> Nest +nestOfContext context + = case context of + ContextRate tRate + -> NestLoop + { nestRate = tRate + , nestStart = [] + , nestBody = [] + , nestInner = NestEmpty + , nestEnd = [] + , nestResult = xUnit } -insertBody (NestList (n:ns)) context body' - | Just (NestList ns') <- insertBody (NestList ns) context body' - = Just $ NestList (n:ns') + ContextSelect{} + -> NestGuard + { nestOuterRate = contextOuterRate context + , nestInnerRate = contextInnerRate context + , nestFlags = contextFlags context + , nestBody = [] + , nestInner = NestEmpty } -insertBody (NestList []) _ _ - = Nothing - -insertBody _ _ _ - = Nothing + ContextSegment{} + -> NestSegment + { nestOuterRate = contextOuterRate context + , nestInnerRate = contextInnerRate context + , nestLength = contextLens context + , nestBody = [] + , nestInner = NestEmpty } -------------------------------------------------------------------------------- --- | Insert ending statements in the given context. -insertEnds :: Nest -> Context -> [StmtEnd] -> Maybe Nest +-- | For selector and segment contexts, make statements that initialize a +-- counter for how many times the context has been entered. +startsForContext :: Context -> Maybe [StmtStart] +startsForContext context + = case context of + ContextSelect{} + -> let TVar (UName nK) = contextInnerRate context + nCounter = NameVarMod nK "count" + in Just [ StartAcc + { startAccName = nCounter + , startAccType = tNat + , startAccExp = xNat 0 }] --- The ends are for this loop. -insertEnds nest@NestLoop{} (ContextRate tRate) ends' - | tRate == nestRate nest - = Just $ nest { nestEnd = nestEnd nest ++ ends' } + ContextSegment{} + -> let TVar (UName nK) = contextInnerRate context + nCounter = NameVarMod nK "count" + in Just [ StartAcc + { startAccName = nCounter + , startAccType = tNat + , startAccExp = xNat 0 }] --- The ends are for some inner context contained by this loop, --- so we can still drop them here. -insertEnds nest@NestLoop{} (ContextRate tRate) ends' - | nestContainsRate nest tRate - = Just $ nest { nestEnd = nestEnd nest ++ ends' } - -insertEnds _ _ _ - = Nothing + _ -> Nothing diff --git a/DDC/Core/Flow/Transform/Schedule/Scalar.hs b/DDC/Core/Flow/Transform/Schedule/Scalar.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Schedule/Scalar.hs @@ -0,0 +1,330 @@ + +module DDC.Core.Flow.Transform.Schedule.Scalar + (scheduleScalar) +where +import DDC.Core.Flow.Transform.Schedule.Nest +import DDC.Core.Flow.Transform.Schedule.Error +import DDC.Core.Flow.Transform.Schedule.Base +import DDC.Core.Flow.Procedure +import DDC.Core.Flow.Process +import DDC.Core.Flow.Compounds +import DDC.Core.Flow.Prim +import DDC.Core.Flow.Exp +import Control.Monad + + +-- | Schedule a process into a procedure, producing scalar code. +scheduleScalar :: Process -> Either Error Procedure +scheduleScalar + (Process { processName = name + , processParamTypes = bsParamTypes + , processParamValues = bsParamValues + , processOperators = operators + , processContexts = contexts}) + = do + -- Check the parameter series all have the same rate. + tK <- slurpRateOfParamTypes + $ filter isSeriesType + $ map typeOfBind bsParamValues + + -- Check the primary rate variable matches the rates of the series. + (case bsParamTypes of + [] -> Left ErrorNoRateParameters + BName n k : _ + | k == kRate + , TVar (UName n) == tK -> return () + _ -> Left ErrorPrimaryRateMismatch) + + -- Create the initial loop nest of the process rate. + let bsSeries = [ b | b <- bsParamValues + , isSeriesType (typeOfBind b) ] + + -- Body expressions that take the next element from each input series. + let ssBody + = [ BodyStmt bElem + (xNext tK tElem (XVar (UName nS)) (XVar uIndex)) + | bS@(BName nS tS) <- bsSeries + , let Just tElem = elemTypeOfSeriesType tS + , let Just bElem = elemBindOfSeriesBind bS + , let uIndex = UIx 0 ] + + -- The initial loop nest. + let nest0 + = NestLoop + { nestRate = tK + , nestStart = [] + , nestBody = ssBody + , nestInner = NestEmpty + , nestEnd = [] + , nestResult = xUnit } + + -- Create the nested contexts + let Just nest1 = foldM insertContext nest0 contexts + + -- Schedule the series operators into the nest. + nest2 <- foldM scheduleOperator nest1 operators + + return $ Procedure + { procedureName = name + , procedureParamTypes = bsParamTypes + , procedureParamValues = bsParamValues + , procedureNest = nest2 } + + +------------------------------------------------------------------------------- +-- | Schedule a single series operator into a loop nest. +scheduleOperator + :: Nest -- ^ The current loop nest. + -> Operator -- ^ Operator to schedule. + -> Either Error Nest + +scheduleOperator nest0 op + + -- Id ------------------------------------------- + | OpId{} <- op + = do let tK = opInputRate op + + -- Get binders for the input elements. + let Just bResult = elemBindOfSeriesBind (opResultSeries op) + let Just uInput = elemBoundOfSeriesBound (opInputSeries op) + + let Just nest1 + = insertBody nest0 tK + $ [ BodyStmt bResult (XVar uInput) ] + + return nest1 + + -- Rep ----------------------------------------- + | OpRep{} <- op + = do let tK = opOutputRate op + + -- Make a binder for the replicated element. + let BName nResult _ = opResultSeries op + let nVal = NameVarMod nResult "val" + let uVal = UName nVal + let bVal = BName nVal (opElemType op) + + -- Get the binder for the use of it in the replicated context. + let Just bResult = elemBindOfSeriesBind (opResultSeries op) + + -- Evaluate the expression to be replicated once, + -- before the main loop. + let Just nest1 + = insertStarts nest0 tK + $ [ StartStmt bVal (opInputExp op) ] + + -- Use the expression for each iteration of the loop. + let Just nest2 + = insertBody nest1 tK + $ [ BodyStmt bResult (XVar uVal) ] + + return nest2 + + -- Reps ---------------------------------------- + | OpReps{} <- op + = do -- Lookup binder for the input element. + let Just uInput = elemBoundOfSeriesBound (opInputSeries op) + + -- Set the result to point to the input element. + let Just bResult = elemBindOfSeriesBind (opResultSeries op) + + let Just nest1 + = insertBody nest0 (opOutputRate op) + $ [ BodyStmt bResult + (XVar uInput)] + + return nest1 + + -- Indices -------------------------------------- + | OpIndices{} <- op + = do + -- In a segment context the variable ^1 is the index into + -- the current segment. + let Just bResult = elemBindOfSeriesBind (opResultSeries op) + + let Just nest1 + = insertBody nest0 (opOutputRate op) + $ [ BodyStmt bResult + (XVar (UIx 1)) ] + + return nest1 + + -- Fill ----------------------------------------- + | OpFill{} <- op + = do let tK = opInputRate op + + -- Get bound of the input element. + let Just uInput = elemBoundOfSeriesBound (opInputSeries op) + + -- Write the current element to the vector. + let UName nVec = opTargetVector op + let Just nest1 + = insertBody nest0 tK + $ [ BodyVecWrite + nVec -- destination vector + (opElemType op) -- series elem type + (XVar (UIx 0)) -- index + (XVar uInput) ] -- value + + -- If the length of the vector corresponds to a guarded rate then it + -- was constructed in a filter context. After the process completes, + -- we know how many elements were written so we can truncate the + -- vector down to its final length. + let Just nest2 + | nestContainsGuardedRate nest1 tK + = insertEnds nest1 tK + $ [ EndVecTrunc + nVec -- destination vector + (opElemType op) -- series element type + tK ] -- rate of source series + + | otherwise + = Just nest1 + + return nest2 + + -- Gather --------------------------------------- + | OpGather{} <- op + = do + let tK = opInputRate op + + -- Bind for result element. + let Just bResult = elemBindOfSeriesBind (opResultBind op) + + -- Bound of source index. + let Just uIndex = elemBoundOfSeriesBound (opSourceIndices op) + + -- Read from the vector. + let Just nest1 = insertBody nest0 tK + $ [ BodyStmt bResult + (xReadVector + (opElemType op) + (XVar $ opSourceVector op) + (XVar $ uIndex)) ] + + return nest1 + + -- Scatter -------------------------------------- + | OpScatter{} <- op + = do + let tK = opInputRate op + + -- Bound of source index. + let Just uIndex = elemBoundOfSeriesBound (opSourceIndices op) + + -- Bound of source elements. + let Just uElem = elemBoundOfSeriesBound (opSourceElems op) + + -- Read from vector. + let Just nest1 = insertBody nest0 tK + $ [ BodyStmt (BNone tUnit) + (xWriteVector + (opElemType op) + (XVar $ opTargetVector op) + (XVar $ uIndex) (XVar $ uElem)) ] + + -- Bind final unit value. + let Just nest2 = insertEnds nest1 tK + $ [ EndStmt (opResultBind op) + xUnit ] + + return nest2 + + -- Maps ----------------------------------------- + | OpMap{} <- op + = do let tK = opInputRate op + + -- Bind for the result element. + let Just bResult = elemBindOfSeriesBind (opResultSeries op) + + -- Binds for all the input elements. + let Just usInput = sequence + $ map elemBoundOfSeriesBound + $ opInputSeriess op + + -- Apply input element vars into the worker body. + let xBody + = foldl (\x (b, p) -> XApp (XLam b x) p) + (opWorkerBody op) + [(b, XVar u) + | b <- opWorkerParams op + | u <- usInput ] + + let Just nest1 + = insertBody nest0 tK + $ [ BodyStmt bResult xBody ] + + return nest1 + + -- Pack ---------------------------------------- + | OpPack{} <- op + = do -- Lookup binder for the input element. + let Just uInput = elemBoundOfSeriesBound (opInputSeries op) + + -- Set the result to point to the input element + let Just bResult = elemBindOfSeriesBind (opResultSeries op) + + let Just nest1 + = insertBody nest0 (opOutputRate op) + $ [ BodyStmt bResult + (XVar uInput)] + + return nest1 + +-- Reduce -------------------------------------- + | OpReduce{} <- op + = do let tK = opInputRate op + + -- Initialize the accumulator. + let UName nResult = opTargetRef op + let nAcc = NameVarMod nResult "acc" + let tAcc = typeOfBind (opWorkerParamAcc op) + + let nAccInit = NameVarMod nResult "init" + + let Just nest1 + = insertStarts nest0 tK + $ [ StartStmt (BName nAccInit tAcc) + (xRead tAcc (XVar $ opTargetRef op)) + , StartAcc nAcc tAcc (XVar (UName nAccInit)) ] + + -- Lookup binders for the input elements. + let Just uInput = elemBoundOfSeriesBound (opInputSeries op) + + -- Bind for intermediate accumulator value. + let nAccVal = NameVarMod nResult "val" + let uAccVal = UName nAccVal + let bAccVal = BName nAccVal tAcc + + -- Substitute input and accumulator vars into worker body. + let xBody x1 x2 + = XApp (XApp ( XLam (opWorkerParamAcc op) + $ XLam (opWorkerParamElem op) + (opWorkerBody op)) + x1) + x2 + + -- Update the accumulator in the loop body. + let Just nest2 + = insertBody nest1 tK + $ [ BodyAccRead nAcc tAcc bAccVal + , BodyAccWrite nAcc tAcc + (xBody (XVar uAccVal) + (XVar uInput)) ] + + -- Read back the final value after the loop has finished and + -- write it to the destination. + let nAccRes = NameVarMod nResult "res" + let Just nest3 + = insertEnds nest2 tK + $ [ EndAcc nAccRes tAcc nAcc + , EndStmt (BNone tUnit) + (xWrite tAcc (XVar $ opTargetRef op) + (XVar $ UName nAccRes)) ] + + return nest3 + + -- Unsupported ---------------------------------- + | otherwise + = Left $ ErrorUnsupported op + diff --git a/DDC/Core/Flow/Transform/Schedule/SeriesEnv.hs b/DDC/Core/Flow/Transform/Schedule/SeriesEnv.hs deleted file mode 100644 --- a/DDC/Core/Flow/Transform/Schedule/SeriesEnv.hs +++ /dev/null @@ -1,157 +0,0 @@ - -module DDC.Core.Flow.Transform.Schedule.SeriesEnv - ( SeriesEnv (..) - , emptySeriesEnv - , insertElemForSeries - - , bindNextElem - , bindNextElems - - , elemBindOfSeriesBind - , elemBoundOfSeriesBound - , elemTypeOfSeriesType - , rateTypeOfSeriesType ) -where -import DDC.Core.Flow.Transform.Schedule.Nest -import DDC.Core.Flow.Procedure -import DDC.Core.Flow.Compounds -import DDC.Core.Flow.Prim -import DDC.Core.Flow.Exp -import qualified Data.Map as Map -import Data.Map (Map) - - -data SeriesEnv - = SeriesEnv - { -- | Maps the bound for a whole series to the bound for - -- a single element in the series context. - envSeriesElems :: Map Name (Bound Name) - } - - --- | An empty series environment. -emptySeriesEnv :: SeriesEnv -emptySeriesEnv - = SeriesEnv Map.empty - - --- | Insert an entry into the series environment. -insertElemForSeries - :: Name -> BoundF -> SeriesEnv -> SeriesEnv - -insertElemForSeries n u (SeriesEnv env) - = SeriesEnv (Map.insert n u env) - - --- | Produce the `Bound` that holds the next element for the given series, --- which exists in the series's context. --- --- We first try to look up the required bound from the series environment, --- if it's not already available then insert a statement into the loop nest --- to get actually get the next element from the series. -bindNextElem - :: Name -- ^ Name of series. - -> TypeF -- ^ Rate of series - -> TypeF -- ^ Series element type. - -> SeriesEnv -- ^ Current series environment. - -> Nest -- ^ Current loop nest. - -> (BoundF, SeriesEnv, Nest) - -bindNextElem nSeries tRate tElem env nest0 - -- There is already a mapping in the environment. - | Just uElem <- Map.lookup nSeries (envSeriesElems env) - = (uElem, env, nest0) - - -- Insert a statement into the loop nest to get the next element - -- from the series. - | otherwise - = let -- bound for the single element - nElem = NameVarMod nSeries "elem" - uElem = UName nElem - - -- Expression to get the next element from the series. - uSeries = UName nSeries - uIndex = UIx 0 - xGet = xNext tRate tElem (XVar uSeries) (XVar uIndex) - - -- Insert the statement into the loop nest. - Just nest1 - = (insertBody nest0 (ContextRate tRate) - [ BodyStmt (BName nElem tElem) xGet ]) - - env' = env { envSeriesElems - = Map.insert nSeries uElem - (envSeriesElems env) } - - in (uElem, env', nest1) - - --- | Like `bindNextElem`, but handle several series at once. -bindNextElems - :: [(Name, TypeF, TypeF)] - -- ^ Names, rates, and element types. - -> SeriesEnv -- ^ Current series environment. - -> Nest -- ^ Current loop nest. - -> ([BoundF], SeriesEnv, Nest) - -bindNextElems junk env nest0 - = case junk of - [] - -> ([], env, nest0) - - (nSeries, tRate, tElem) : junk' - -> let (uElem1, env1, nest1) - = bindNextElem nSeries tRate tElem env nest0 - - (uElems', env', nest') - = bindNextElems junk' env1 nest1 - - in (uElem1 : uElems', env', nest') - - --- | Given the bind of a series, produce the bound that refers to the --- next element of the series in its context. -elemBindOfSeriesBind :: BindF -> Maybe BindF -elemBindOfSeriesBind bSeries - | BName nSeries tSeries' <- bSeries - , nElem <- NameVarMod nSeries "elem" - , Just tElem <- elemTypeOfSeriesType tSeries' - = Just $ BName nElem tElem - - | otherwise - = Nothing - - --- | Given the bound of a series, produce the bound that refers to the --- next element of the series in its context. -elemBoundOfSeriesBound :: BoundF -> Maybe BoundF -elemBoundOfSeriesBound uSeries - | UName nSeries <- uSeries - , nElem <- NameVarMod nSeries "elem" - = Just $ UName nElem - - | otherwise - = Nothing - - --- | Given the type of a series like @Series k e@, produce the type --- of a single element, namely the @e@. -elemTypeOfSeriesType :: TypeF -> Maybe TypeF -elemTypeOfSeriesType tSeries' - | Just (_tcSeries, [_tK, tE]) <- takeTyConApps tSeries' - = Just tE - - | otherwise - = Nothing - - --- | Given the type of a series like @Series k e@, produce the type --- of the rate, namely the @k@. -rateTypeOfSeriesType :: TypeF -> Maybe TypeF -rateTypeOfSeriesType tSeries' - | Just (_tcSeries, [tK, _tE]) <- takeTyConApps tSeries' - = Just tK - - | otherwise - = Nothing - diff --git a/DDC/Core/Flow/Transform/Slurp.hs b/DDC/Core/Flow/Transform/Slurp.hs --- a/DDC/Core/Flow/Transform/Slurp.hs +++ b/DDC/Core/Flow/Transform/Slurp.hs @@ -1,8 +1,11 @@ module DDC.Core.Flow.Transform.Slurp - (slurpProcesses) + ( slurpProcesses + , slurpOperator + , isSeriesOperator + , isVectorOperator) where -import DDC.Core.Flow.Transform.Slurp.Alloc import DDC.Core.Flow.Transform.Slurp.Operator +import DDC.Core.Flow.Transform.Slurp.Error import DDC.Core.Flow.Prim import DDC.Core.Flow.Context import DDC.Core.Flow.Process @@ -10,45 +13,58 @@ import DDC.Core.Flow.Exp import DDC.Core.Transform.Deannotate import DDC.Core.Module -import Data.Maybe +import qualified DDC.Type.Env as Env +import DDC.Type.Env (TypeEnv) import Data.List -- | Slurp stream processes from the top level of a module. -slurpProcesses :: Module () Name -> [Process] +slurpProcesses :: Module () Name -> Either Error [Process] slurpProcesses mm = slurpProcessesX (deannotate (const Nothing) $ moduleBody mm) -- | Slurp stream processes from a module body. -slurpProcessesX :: Exp () Name -> [Process] +-- A module consists of some let-bindings wrapping a unit data constructor. +slurpProcessesX :: Exp () Name -> Either Error [Process] slurpProcessesX xx = case xx of + -- Slurp processes definitions from the let-bindings. XLet lts x' - -> slurpProcessesLts lts ++ slurpProcessesX x' + -> do ps1 <- slurpProcessesLts lts + ps2 <- slurpProcessesX x' + return $ ps1 ++ ps2 - _ -> [] + -- Ignore the unit data constructor at the end of the module. + _ + | xx == xUnit -> Right [] + | otherwise -> Left $ ErrorBadProcess xx -- | Slurp stream processes from the top-level let expressions. -slurpProcessesLts :: Lets () Name -> [Process] +slurpProcessesLts :: Lets () Name -> Either Error [Process] slurpProcessesLts (LRec binds) - = catMaybes [slurpProcessLet b x | (b, x) <- binds] + = sequence [slurpProcessLet b x | (b, x) <- binds] slurpProcessesLts (LLet b x) - = catMaybes [slurpProcessLet b x] + = sequence [slurpProcessLet b x] slurpProcessesLts _ - = [] + = return [] ------------------------------------------------------------------------------- -- | Slurp stream operators from a top-level binding. -slurpProcessLet :: Bind Name -> Exp () Name -> Maybe Process -slurpProcessLet (BName n tProcess) xx +slurpProcessLet + :: Bind Name -- ^ Binder for the whole process. + -> Exp () Name -- ^ Expression of body. + -> Either Error Process +slurpProcessLet (BName n t) xx + -- We assume that all type params come before the value params. - | Just (fbs, xBody) <- takeXLamFlags xx + | (snd $ takeTFunAllArgResult t) == tProcess + , Just (fbs, xBody) <- takeXLamFlags xx = let -- Split binders into type and value binders. (fbts, fbvs) = partition fst fbs @@ -66,16 +82,11 @@ bvs = map snd fbvs -- Slurp the body of the process. - (ctxLocal, ops, ltss, xResult) - = slurpProcessX xBody - - -- Decide what rates to use when allocating vectors. - ops_alloc = patchAllocRates ops - - -- Determine the type of the result of the process. - tResult = snd $ takeTFunAllArgResult tProcess + in do + (ctxLocal, ops) + <- slurpProcessX Env.empty xBody - in Just $ Process + return $ Process { processName = n , processParamTypes = bts , processParamValues = bvs @@ -85,115 +96,189 @@ -- are inside , processContexts = ctxParam ++ ctxLocal - , processOperators = ops_alloc - , processStmts = ltss - , processResultType = tResult - , processResult = xResult } + , processOperators = ops } -slurpProcessLet _ _ - = Nothing +slurpProcessLet _ xx + = Left (ErrorBadProcess xx) ------------------------------------------------------------------------------- -- | Slurp stream operators from the body of a function and add them to --- the provided loop nest. +-- the provided loop nest. +-- +-- The process type environment records what process bindings are in scope, +-- so that we can check that the overall process is well formed. +-- This environment only needs to contain locally defined process variables, +-- not the global environment for the whole module. +-- slurpProcessX - :: ExpF -- A sequence of non-recursive let-bindings. - -> ( [Context] -- Nested contexts created by this process. - , [Operator] -- Series operators in this binding. - , [LetsF] -- Baseband statements that don't process series. - , ExpF) -- Final value of process. + :: TypeEnv Name -- ^ Process type environment. + -> ExpF -- ^ A sequence of non-recursive let-bindings. + -> Either Error + ( [Context] -- Nested contexts created by this process. + , [Operator]) -- Series operators in this binding. -slurpProcessX xx - | XLet (LLet b x) xMore <- xx - , (ctxHere, opsHere, ltsHere) <- slurpBindingX b x - , (ctxMore, opsMore, ltsMore, xResult) <- slurpProcessX xMore - = ( ctxHere ++ ctxMore - , opsHere ++ opsMore - , ltsHere ++ ltsMore - , xResult) +slurpProcessX tenv xx + | XLet (LLet b x) xMore <- xx + = do + -- Slurp operators from the binding. + (ctxHere, opsHere) <- slurpBindingX tenv b x - -- Only handle very simple cases with one alt for now. - -- 'Invert' the case and create a let binding for each binder. - -- We can safely duplicate xScrut since it's in ANF. - | XCase xScrut [AAlt (PData dc bs) x] <- xx - , bs' <- takeSubstBoundsOfBinds bs - , length bs == length bs' - , lets <- zipWith - (\b b' -> LLet b - (XCase xScrut - [AAlt (PData dc bs) - (XVar b')])) bs bs' - = slurpProcessX (xLets lets x) + -- If this binding defined a process then add it do the environment. + let tenv' + | typeOfBind b == tProcess = Env.extend b tenv + | otherwise = tenv + -- Slurp the rest of the process using the new environment. + (ctxMore, opsMore) <- slurpProcessX tenv' xMore + + return ( ctxHere ++ ctxMore + , opsHere ++ opsMore) + +-- Slurp a process ending. +slurpProcessX tenv xx + -- The process ends with a variable that has Process# type. + | XVar u <- xx + , Just t <- Env.lookup u tenv + , t == tProcess + = return ([], []) + + -- The process ends by joining two existing processes. + -- We assume that the overall expression is well typed. + | Just (NameOpSeries OpSeriesJoin, [_, _]) + <- takeXPrimApps xx + = return ([], []) + + -- Process finishes with some expression that doesn't look like it + -- actually defines a value of type Process#. | otherwise - = ([], [], [], xx) + = Left (ErrorBadProcess xx) ------------------------------------------------------------------------------- -- | Slurp stream operators from a let-binding. slurpBindingX - :: BindF -- Binder to assign result to. - -> ExpF -- Right of the binding. - -> ( [Context] -- Nested contexts created by this binding. - , [Operator] -- Series operators in this binding. - , [LetsF]) -- Baseband statements that don't process series. + :: TypeEnv Name -- ^ Process type environment. + -> BindF -- ^ Binder to assign result to. + -> ExpF -- ^ Right of the binding. + -> Either + Error + ( [Context] -- Nested contexts created by this binding. + , [Operator]) -- Series operators in this binding. + -- Decend into more let bindings. -- We get these when entering into a nested context. -slurpBindingX b1 xx +slurpBindingX tenv b1 xx | XLet (LLet b2 x2) xMore <- xx - , (ctxHere, opsHere, ltsHere) <- slurpBindingX b2 x2 - , (ctxMore, opsMore, ltsMore) <- slurpBindingX b1 xMore - = ( ctxHere ++ ctxMore - , opsHere ++ opsMore - , ltsHere ++ ltsMore) + = do + -- Slurp operators from the binding. + (ctxHere, opsHere) <- slurpBindingX tenv b2 x2 + -- If this binding defined a process then add it to the environement. + let tenv' + | typeOfBind b2 == tProcess = Env.extend b2 tenv + | otherwise = tenv + + -- Slurp the rest of the process using the new environment. + (ctxMore, opsMore) <- slurpBindingX tenv' b1 xMore + + return ( ctxHere ++ ctxMore + , opsHere ++ opsMore) + + -- Slurp a mkSel1# -- This creates a nested selector context. -slurpBindingX b +slurpBindingX tenv b ( takeXPrimApps - -> Just ( NameOpFlow (OpFlowMkSel 1) - , [ XType tK1, XType _tA + -> Just ( NameOpSeries (OpSeriesMkSel 1) + , [ XType tK1 , XVar uFlags , XLAM (BName nR kR) (XLam bSel xBody)])) | kR == kRate - = let - (ctxInner, osInner, ltsInner) - = slurpBindingX b xBody + = do + (ctxInner, osInner) + <- slurpBindingX tenv b xBody -- Add an intermediate edge from the flags variable to its use. -- This is needed for the case when the flags series is one of the -- parameters to the process, because the intermediate OpId forces -- the scheduler to add the flags_elem = next [k] flags_series -- statement. - UName nFlags = uFlags - nFlagsUse = NameVarMod nFlags "use" - uFlagsUse = UName nFlagsUse - bFlagsUse = BName nFlagsUse (tSeries tK1 tBool) + let UName nFlags = uFlags + let nFlagsUse = NameVarMod nFlags "use" + let uFlagsUse = UName nFlagsUse + let bFlagsUse = BName nFlagsUse (tSeries tK1 tBool) - opId = OpId - { opResultSeries = bFlagsUse - , opInputRate = tK1 - , opInputSeries = uFlags - , opElemType = tBool } + let opId = OpId + { opResultSeries = bFlagsUse + , opInputRate = tK1 + , opInputSeries = uFlags + , opElemType = tBool } - context = ContextSelect - { contextOuterRate = tK1 - , contextInnerRate = TVar (UName nR) - , contextFlags = uFlagsUse - , contextSelector = bSel } + let context = ContextSelect + { contextOuterRate = tK1 + , contextInnerRate = TVar (UName nR) + , contextFlags = uFlagsUse + , contextSelector = bSel } - in (context : ctxInner, opId : osInner, ltsInner) + return (context : ctxInner, opId : osInner) --- | Slurp an operator that doesn't introduce a new context. -slurpBindingX b x - = case slurpOperator b x of - -- This binding is a flow operator. - Just op -> ([], [op], []) +-- Slurp a mkSegd#. +-- This creates a segmented context. +slurpBindingX tenv b + ( takeXPrimApps + -> Just ( NameOpSeries OpSeriesMkSegd + , [ XType tK1 + , XVar uLens + , XLAM (BName nK2 kR) (XLam bSegd xBody)])) + | kR == kRate + = do + (ctxInner, osInner) + <- slurpBindingX tenv b xBody - -- This is some base-band statement that doesn't - -- work on a flow operator. - _ -> ([], [], [LLet b x]) + let UName nLens = uLens + let nLensUse = NameVarMod nLens "use" + let uLensUse = UName nLensUse + let bLensUse = BName nLensUse (tSeries tK1 tNat) + + let opId = OpId + { opResultSeries = bLensUse + , opInputRate = tK1 + , opInputSeries = uLens + , opElemType = tNat } + + let context = ContextSegment + { contextOuterRate = tK1 + , contextInnerRate = TVar (UName nK2) + , contextLens = uLensUse + , contextSegd = bSegd } + + return (context : ctxInner, opId : osInner) + + +-- Slurp a series operator that doesn't introduce a new context. +slurpBindingX _ b xx + | Just op <- slurpOperator b xx + = return ([], [op]) + +-- Slurp a process ending. +slurpBindingX tenv _ xx + -- The process ends with a variable that has Process# type. + | XVar u <- xx + , Just t <- Env.lookup u tenv + , t == tProcess + = return ([], []) + + -- The process ends by joining two existing processes. + -- We assume that the overall expression is well typed. + | Just (NameOpSeries OpSeriesJoin, [_, _]) + <- takeXPrimApps xx + = return ([], []) + + -- Process finishes with some expression that doesn't look like it + -- actually defines a value of type Process#. + | otherwise + = Left (ErrorBadOperator xx) diff --git a/DDC/Core/Flow/Transform/Slurp/Alloc.hs b/DDC/Core/Flow/Transform/Slurp/Alloc.hs deleted file mode 100644 --- a/DDC/Core/Flow/Transform/Slurp/Alloc.hs +++ /dev/null @@ -1,41 +0,0 @@ - -module DDC.Core.Flow.Transform.Slurp.Alloc - (patchAllocRates) -where -import DDC.Core.Flow.Process.Operator - - --- | Decide what rates should be used to allocate created vectors. --- When a vector is being created in a selector context then we need to --- use the maximum possible length, which is the outer context instead --- of the inner one created by the selector. -patchAllocRates :: [Operator] -> [Operator] -patchAllocRates ops - = let - -- Build a table of output to input rates for all pack operations. - packRates - = [ (opOutputRate op, opInputRate op) - | op@OpPack{} <- ops ] - - -- Fix the number of nested contexts to some finite number so we - -- don't end up diverging if there is a loop in the list of - -- operator descriptions. - maxNestedContexts = 1000 :: Int - - getAllocRate 0 _rate - = error $ unlines - [ "ddc-core-flow.patchAllocRates" - , " Too many nested contexts." ] - - getAllocRate n rate - = case lookup rate packRates of - Just inRate -> getAllocRate (n - 1) inRate - _ -> rate - - patchOperator op@OpCreate{} - = op { opAllocRate = Just $ getAllocRate maxNestedContexts (opInputRate op) } - - patchOperator op - = op - - in map patchOperator ops diff --git a/DDC/Core/Flow/Transform/Slurp/Error.hs b/DDC/Core/Flow/Transform/Slurp/Error.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Slurp/Error.hs @@ -0,0 +1,33 @@ + +module DDC.Core.Flow.Transform.Slurp.Error + (Error (..)) +where +import DDC.Core.Flow.Exp +import DDC.Core.Flow.Prim +import DDC.Core.Transform.Annotate +import DDC.Core.Pretty + + +-- | Things that can go wrong when slurping a process spec from +-- Disciple Core Flow code. +data Error + -- | Invalid series process definition. + = ErrorBadProcess (Exp () Name) + + -- | Invalid operator definition in process. + | ErrorBadOperator (Exp () Name) + deriving Show + + +instance Pretty Error where + ppr err + = case err of + ErrorBadProcess x + -> vcat [ text "Bad series process definition." + , empty + , ppr (annotate () x) ] + + ErrorBadOperator x + -> vcat [ text "Bad series operator." + , empty + , ppr (annotate () x) ] diff --git a/DDC/Core/Flow/Transform/Slurp/Operator.hs b/DDC/Core/Flow/Transform/Slurp/Operator.hs --- a/DDC/Core/Flow/Transform/Slurp/Operator.hs +++ b/DDC/Core/Flow/Transform/Slurp/Operator.hs @@ -1,13 +1,15 @@ module DDC.Core.Flow.Transform.Slurp.Operator - (slurpOperator) + ( slurpOperator + , isSeriesOperator + , isVectorOperator) where import DDC.Core.Flow.Process.Operator import DDC.Core.Flow.Exp import DDC.Core.Flow.Prim -import DDC.Core.Flow.Prim.TyConPrim import DDC.Core.Compounds.Simple -import DDC.Type.Pretty () +import DDC.Core.Pretty () +import Control.Monad -- | Slurp a stream operator from a let-binding binding. @@ -18,20 +20,78 @@ -> Maybe Operator slurpOperator bResult xx + + -- Rep ----------------------------------------- + | Just ( NameOpSeries OpSeriesRep + , [ XType tK1, XType tA, xVal]) + <- takeXPrimApps xx + = Just $ OpRep + { opResultSeries = bResult + , opOutputRate = tK1 + , opElemType = tA + , opInputExp = xVal } - -- Create -------------------------------------- - | Just ( NameOpFlow OpFlowVectorOfSeries - , [ XType tRate, XType tA, (XVar uSeries) ]) + -- Reps ---------------------------------------- + | Just ( NameOpSeries OpSeriesReps + , [ XType tK1, XType tK2, XType tA, XVar uSegd, XVar uS ]) <- takeXPrimApps xx - = Just $ OpCreate - { opResultVector = bResult - , opInputRate = tRate - , opInputSeries = uSeries - , opAllocRate = Nothing + = Just $ OpReps + { opResultSeries = bResult + , opInputRate = tK1 + , opOutputRate = tK2 + , opElemType = tA + , opSegdBound = uSegd + , opInputSeries = uS } + + -- Indices ------------------------------------- + | Just ( NameOpSeries OpSeriesIndices + , [ XType tK1, XType tK2, XVar uSegd]) + <- takeXPrimApps xx + = Just $ OpIndices + { opResultSeries = bResult + , opInputRate = tK1 + , opOutputRate = tK2 + , opSegdBound = uSegd } + + -- Fill ---------------------------------------- + | Just ( NameOpSeries OpSeriesFill + , [ XType tK, XType tA, XVar uV, XVar uS ]) + <- takeXPrimApps xx + = Just $ OpFill + { opResultBind = bResult + , opTargetVector = uV + , opInputRate = tK + , opInputSeries = uS , opElemType = tA } + + -- Gather -------------------------------------- + | Just ( NameOpSeries OpSeriesGather + , [ XType tK, XType tA, XVar uV, XVar uS ]) + <- takeXPrimApps xx + = Just $ OpGather + { opResultBind = bResult + , opSourceVector = uV + , opSourceIndices = uS + , opInputRate = tK + , opElemType = tA } + + + -- Scatter ------------------------------------- + | Just ( NameOpSeries OpSeriesScatter + , [ XType tK, XType tA, XVar uV, XVar uIndices, XVar uElems ]) + <- takeXPrimApps xx + = Just $ OpScatter + { opResultBind = bResult + , opTargetVector = uV + , opSourceIndices = uIndices + , opSourceElems = uElems + , opInputRate = tK + , opElemType = tA } + + -- Map ----------------------------------------- - | Just (NameOpFlow (OpFlowMap n), xs) + | Just (NameOpSeries (OpSeriesMap n), xs) <- takeXPrimApps xx , n >= 1 , XType tR : xsArgs2 <- xs @@ -52,42 +112,8 @@ , opWorkerBody = xBody } - -- Fold ---------------------------------------- - | Just ( NameOpFlow OpFlowFold - , [ XType tRate, XType _tAcc, XType _tElem - , xWorker, xZero, (XVar uSeries)]) - <- takeXPrimApps xx - , Just ([pAcc, pElem], xBody) <- takeXLams xWorker - = Just $ OpFold - { opResultValue = bResult - , opInputRate = tRate - , opInputSeries = uSeries - , opZero = xZero - , opWorkerParamIndex = BNone tInt - , opWorkerParamAcc = pAcc - , opWorkerParamElem = pElem - , opWorkerBody = xBody } - - - -- FoldIndex ----------------------------------- - | Just ( NameOpFlow OpFlowFoldIndex - , [ XType tRate, XType _tAcc, XType _tElem - , xWorker, xZero, (XVar uSeries)]) - <- takeXPrimApps xx - , Just ([pIx, pAcc, pElem], xBody) <- takeXLams xWorker - = Just $ OpFold - { opResultValue = bResult - , opInputRate = tRate - , opInputSeries = uSeries - , opZero = xZero - , opWorkerParamIndex = pIx - , opWorkerParamAcc = pAcc - , opWorkerParamElem = pElem - , opWorkerBody = xBody } - - -- Pack ---------------------------------------- - | Just ( NameOpFlow OpFlowPack + | Just ( NameOpSeries OpSeriesPack , [ XType tRateInput, XType tRateOutput, XType tElem , _xSel, (XVar uSeries) ]) <- takeXPrimApps xx = Just $ OpPack @@ -97,6 +123,39 @@ , opOutputRate = tRateOutput , opElemType = tElem } + + -- Reduce -------------------------------------- + | Just ( NameOpSeries OpSeriesReduce + , [ XType tK, XType _ + , XVar uRef, xWorker, xZ, XVar uS ]) + <- takeXPrimApps xx + , Just ([bAcc, bElem], xBody) <- takeXLams xWorker + = Just $ OpReduce + { opResultBind = bResult + , opTargetRef = uRef + , opInputRate = tK + , opInputSeries = uS + , opZero = xZ + , opWorkerParamAcc = bAcc + , opWorkerParamElem = bElem + , opWorkerBody = xBody } + | otherwise = Nothing + + +-- | Check if some binding is a series operator. +isSeriesOperator :: Exp () Name -> Bool +isSeriesOperator xx + = case liftM fst $ takeXPrimApps xx of + Just (NameOpSeries _) -> True + _ -> False + + +-- | Check if some binding is a vector operator. +isVectorOperator :: Exp () Name -> Bool +isVectorOperator xx + = case liftM fst $ takeXPrimApps xx of + Just (NameOpVector _) -> True + _ -> False diff --git a/DDC/Core/Flow/Transform/Thread.hs b/DDC/Core/Flow/Transform/Thread.hs --- a/DDC/Core/Flow/Transform/Thread.hs +++ b/DDC/Core/Flow/Transform/Thread.hs @@ -28,7 +28,7 @@ , configVoidType = tUnit , configWrapResultType = wrapResultType , configWrapResultExp = wrapResultExp - , configThreadMe = threadType + , configThreadMe = threadType , configThreadPat = unwrapResult } @@ -45,53 +45,38 @@ -- | Wrap the result of a stateful computation with the state token. -wrapResultExp +wrapResultExp :: Exp (AnTEC () Name) Name -- ^ World expression -> Exp (AnTEC () Name) Name -- ^ Result expression -> Exp () Name wrapResultExp xWorld xResult -- Rewrite Unit => World - | Just aResult <- takeAnnotOfExp xResult - , annotType aResult == tUnit + | aResult <- annotOfExp xResult + , annotType aResult == tUnit = reannotate annotTail xWorld - -- Rewrite (TupleN a1 a2 .. x1 x2 ..) + -- Rewrite (TupleN a1 a2 .. x1 x2 ..) -- => (TupleN World# a1 a2 .. world x1 x2 ..) - | Just aWorld <- takeAnnotOfExp xWorld - , Just aResult <- takeAnnotOfExp xResult + | aWorld <- annotOfExp xWorld + , aResult <- annotOfExp xResult = let tWorld' = annotType aWorld tResult = annotType aResult xWorld' = reannotate annotTail xWorld xResult' = reannotate annotTail xResult - in - -- ISSUE #308: Handle Tuple arities generically in thread transform. - case C.takeXConApps xResult' of - Just (dc, [xT1, xT2 - , x1, x2]) - | dc == dcTupleN 2 - -> C.xApps () (XCon () (dcTupleN 3)) - [ XType tWorld', xT1, xT2 - , xWorld', x1, x2] - - Just (dc, [xT1, xT2, xT3 - , x1, x2, x3]) - | dc == dcTupleN 3 - -> C.xApps () (XCon () (dcTupleN 4)) - [ XType tWorld', xT1, xT2, xT3 - , xWorld', x1, x2, x3] - - Just (dc, [xT1, xT2, xT3, xT4 - , x1, x2, x3, x4]) - | dc == dcTupleN 4 - -> C.xApps () (XCon () (dcTupleN 5)) - [ XType tWorld', xT1, xT2, xT3, xT4 - , xWorld', x1, x2, x3, x4] - + in case C.takeXConApps xResult' of + Just (dc, xa) + | DaConPrim (NameDaConFlow (DaConFlowTuple n)) _ <- dc + , x <- length xa + , x >= 2 + -> let (b, a) = splitAt (x `quot` 2) xa + in C.xApps () (XCon () (dcTupleN $ n + 1)) + $ XType (annotTail aWorld) tWorld' : b -- World# : a1 a2 .. + ++ xWorld' : a -- world : x1 x2 .. _ -> C.xApps () (XCon () (dcTupleN 2)) - [ XType tWorld' - , XType tResult + [ XType (annotTail aWorld) tWorld' + , XType (annotTail aResult) tResult , xWorld' , xResult' ] @@ -104,10 +89,10 @@ unwrapResult _ = Just unwrap - where unwrap bWorld bsResult + where unwrap bWorld bsResult | [bResult] <- bsResult , typeOfBind bResult == tUnit - = PData dcTuple1 [bWorld] + = PData dcTuple1 [bWorld] | otherwise = PData (dcTupleN (length (bWorld : bsResult))) @@ -124,80 +109,98 @@ -- Assignables -------------------------- -- new# :: [a : Data]. a -> World# -> T2# (World#, Ref# a) NameOpStore OpStoreNew - -> Just $ tForall kData - $ \tA -> tA + -> Just $ tForall kData + $ \tA -> tA `tFun` tWorld `tFun` (tTuple2 tWorld (tRef tA)) -- read# :: [a : Data]. Ref# a -> World# -> T2# (World#, a) NameOpStore OpStoreRead -> Just $ tForall kData - $ \tA -> tRef tA + $ \tA -> tRef tA `tFun` tWorld `tFun` (tTuple2 tWorld (tRef tA)) -- write# :: [a : Data]. Ref# -> a -> World# -> World# - NameOpStore OpStoreWrite + NameOpStore OpStoreWrite -> Just $ tForall kData - $ \tA -> tRef tA `tFun` tA + $ \tA -> tRef tA `tFun` tA `tFun` tWorld `tFun` tWorld -- Vectors ------------------------------- - -- newVector# :: [a : Data]. Nat# -> World# -> T2# World# (Vector# a) + -- vnew# :: [a : Data]. Nat# -> World# -> T2# World# (Vector# a) NameOpStore OpStoreNewVector -> Just $ tForall kData - $ \tA -> tNat + $ \tA -> tNat `tFun` tWorld `tFun` (tTuple2 tWorld (tVector tA)) - -- newVectorN# :: [a : Data]. [k : Rate]. RateNat# k - -- -> World# -> T2# (World#, Vector# a) + -- vnew# :: [a : Data]. [k : Rate]. RateNat# k + -- -> World# -> T2# (World#, Vector# a) NameOpStore OpStoreNewVectorN -> Just $ tForalls [kData, kRate] - $ \[tA, tK] - -> tRateNat tK + $ \[tA, tK] + -> tRateNat tK `tFun` tWorld `tFun` (tTuple2 tWorld (tVector tA)) - -- readVector# :: [a : Data]. Vector# a -> Nat# -> World# -> T2# World# a - NameOpStore OpStoreReadVector + -- vread# :: [a : Data]. Vector# a -> Nat# -> World# -> T2# World# a + NameOpStore (OpStoreReadVector _) -> Just $ tForall kData - $ \tA -> tA `tFun` tVector tA `tFun` tNat + $ \tA -> tA `tFun` tVector tA `tFun` tNat `tFun` tWorld `tFun` (tTuple2 tWorld tA) - -- writeVector# :: [a : Data]. Vector# a -> Nat# -> a -> World# -> World# - NameOpStore OpStoreWriteVector + -- vwrite# :: [a : Data]. Vector# a -> Nat# -> a -> World# -> World# + NameOpStore (OpStoreWriteVector _) -> Just $ tForall kData - $ \tA -> tA `tFun` tVector tA `tFun` tNat `tFun` tA + $ \tA -> tA `tFun` tVector tA `tFun` tNat `tFun` tA `tFun` tWorld `tFun` tWorld - -- sliceVector# :: [a : Data]. Nat# -> Vector# a -> World# -> T2# World# (Vector# a) - NameOpStore OpStoreSliceVector + -- vtrunc# :: [a : Data]. Nat# -> Vector# a -> World# -> World# + NameOpStore OpStoreTruncVector -> Just $ tForall kData - $ \tA -> tNat `tFun` tVector tA - `tFun` tWorld `tFun` (tTuple2 tWorld (tVector tA)) - + $ \tA -> tNat `tFun` tVector tA + `tFun` tWorld `tFun` tWorld - -- Streams ------------------------------ + -- Series ------------------------------ -- next# :: [k : Rate]. [a : Data] -- . Series# k a -> Int# -> World# -> (World#, a) - NameOpStore OpStoreNext + NameOpConcrete (OpConcreteNext 1) -> Just $ tForalls [kRate, kData] - $ \[tK, tA] -> tSeries tK tA `tFun` tInt + $ \[tK, tA] -> tSeries tK tA `tFun` tInt `tFun` tWorld `tFun` (tTuple2 tWorld tA) - -- Contexts ----------------------------- - -- loopn# :: [k : Rate]. RateNat# k - -- -> (Nat# -> World# -> World#) + -- nextN# :: [k : Rate]. [a : Data] + -- . Series# k a -> Int# -> World# -> (World#, a) + NameOpConcrete (OpConcreteNext c) + | c >= 2 + -> Just $ tForalls [kRate, kData] + $ \[tK, tA] -> tSeries (tDown c tK) tA `tFun` tInt + `tFun` tWorld `tFun` (tTuple2 tWorld (tVec c tA)) + + -- Control ----------------------------- + -- loopn# :: [k : Rate]. RateNat# k + -- -> (Nat# -> World# -> World#) -- -> World# -> World# - NameOpLoop OpLoopLoopN + NameOpControl OpControlLoopN -> Just $ tForalls [kRate] $ \[tK] -> tRateNat tK `tFun` (tNat `tFun` tWorld `tFun` tWorld) `tFun` tWorld `tFun` tWorld - + -- guard# - NameOpLoop OpLoopGuard + NameOpControl OpControlGuard -> Just $ tRef tNat `tFun` tBool `tFun` (tNat `tFun` tWorld `tFun` tWorld) `tFun` tWorld `tFun` tWorld + + -- split# :: [k : Rate]. RateNat# k + -- -> (RateNat# (Down8# k) -> World# -> World#) + -- -> (RateNat# (Tail8# k) -> World# -> World#) + -- -> World# -> World# + NameOpControl (OpControlSplit c) + -> Just $ tForall kRate + $ \tK -> tRateNat tK + `tFun` (tRateNat (tDown c tK) `tFun` tWorld `tFun` tWorld) + `tFun` (tRateNat (tTail c tK) `tFun` tWorld `tFun` tWorld) + `tFun` tWorld `tFun` tWorld _ -> Nothing diff --git a/DDC/Core/Flow/Transform/Wind.hs b/DDC/Core/Flow/Transform/Wind.hs --- a/DDC/Core/Flow/Transform/Wind.hs +++ b/DDC/Core/Flow/Transform/Wind.hs @@ -32,7 +32,8 @@ import DDC.Core.Flow import DDC.Core.Flow.Prim import DDC.Core.Compounds -import DDC.Core.Flow.Compounds (tNat, dcNat, dcTupleN, dcBool, tTupleN) +import DDC.Core.Flow.Compounds + (tNat, dcNat, dcTupleN, dcBool, tTupleN) import qualified Data.Map as Map import Data.Map (Map) @@ -112,6 +113,14 @@ deriving Show +-- | Check if some `Context` is a `ContextLoop`. +isContextLoop :: Context -> Bool +isContextLoop cc + = case cc of + ContextLoop{} -> True + _ -> False + + -- | Build a tailcall from the current context. -- This tells us where to go after finishing the body of a loop. makeTailCallFromContexts :: a -> RefMap -> [Context] -> Exp a Name @@ -122,12 +131,14 @@ in xApps a xLoop xArgs -makeTailCallFromContexts _ _ _ +makeTailCallFromContexts _ _ contexts = error $ unlines [ "ddc-core-flow.makeTailCallFromContexts" - , " Can't make a tailcall for this context." ] + , " Can't make a tailcall for this context." + , " context = " ++ show contexts ] +------------------------------------------------------------------------------- -- | Slurp expressions to update each of the accumulators of the loop. -- We assume that there have been no other updates to the loop -- counter, and we generated the code ourselves. @@ -183,17 +194,18 @@ xIncrement a xx = xApps a (XVar a (UPrim (NamePrimArith PrimArithAdd) (typePrimArith PrimArithAdd))) - [ XType tNat, xx, XCon a (dcNat 1) ] + [ XType a tNat, xx, XCon a (dcNat 1) ] -- | Build an expression that substracts two integers. xSubInt :: a -> Exp a Name -> Exp a Name -> Exp a Name xSubInt a x1 x2 = xApps a (XVar a (UPrim (NamePrimArith PrimArithSub) (typePrimArith PrimArithSub))) - [ XType tNat, x1, x2] + [ XType a tNat, x1, x2] ------------------------------------------------------------------------------- +-- | Apply the wind transform to a single module. windModule :: Module () Name -> Module () Name windModule m = let body' = windModuleBodyX (moduleBody m) @@ -242,7 +254,7 @@ -- XLet a (LLet (BName nRef _) x) x2 | Just ( NameOpStore OpStoreNew - , [XType tElem, xVal] ) <- takeXPrimApps x + , [XType _ tElem, xVal] ) <- takeXPrimApps x -> let -- Add the new ref record to the map. info = RefInfo @@ -268,7 +280,7 @@ -- XLet a (LLet bResult x) x2 | Just ( NameOpStore OpStoreRead - , [XType _tElem, XVar _ (UName nRef)] ) + , [XType _ _tElem, XVar _ (UName nRef)] ) <- takeXPrimApps x , Just info <- lookupRefInfo refMap nRef , Just nVal <- nameOfRefInfo info @@ -281,7 +293,7 @@ -- to just bind the new value. XLet a (LLet (BNone _) x) x2 | Just ( NameOpStore OpStoreWrite - , [XType _tElem, XVar _ (UName nRef), xVal]) + , [XType _ _tElem, XVar _ (UName nRef), xVal]) <- takeXPrimApps x , refMap' <- bumpVersionInRefMap nRef refMap , Just info <- lookupRefInfo refMap' nRef @@ -294,17 +306,16 @@ ----------------------------------------- -- Detect loop combinator. XLet a (LLet (BNone _) x) x2 - | Just ( NameOpLoop OpLoopLoopN - , [ XType tK, xLength + | Just ( NameOpControl OpControlLoopN + , [ XType _ tK, xLength , XLam _ bIx@(BName nIx _) xBody]) <- takeXPrimApps x -> let -- Name of the new loop function. - TVar (UName nK) = tK - nLoop = NameVarMod nK "loop" + nLoop = NameVar "loop" bLoop = BName nLoop tLoop uLoop = UName nLoop - nLength = NameVarMod nK "length" + nLength = NameVarMod nLoop "length" bLength = BName nLength tNat uLength = UName nLength @@ -383,7 +394,7 @@ ----------------------------------------- -- Detect guard combinator. XLet a (LLet (BNone _) x) x2 - | Just ( NameOpLoop OpLoopGuard + | Just ( NameOpControl OpControlGuard , [ XVar _ (UName nCountRef) , xFlag , XLam _ bCount xBody ]) <- takeXPrimApps x @@ -407,13 +418,24 @@ ----------------------------------------- -- Detect end value. - -- When we hit a Unit at the top level of the body of a loop then - -- we know it's time to do the recursive call. + -- If we're inside a loop and hit a Unit at the top-level of the body + -- then we know it's time to do the recursive call. XCon a dc - | dc == dcUnit + | any isContextLoop context + , dc == dcUnit -> makeTailCallFromContexts a refMap context + ----------------------------------------- + -- Enter into both branches of a split. + XApp{} + | Just ( NameOpControl (OpControlSplit n) + , [ XType _ tK, xN, xBranch1, xBranch2 ]) <- takeXPrimApps xx + -> let xBranch1' = down xBranch1 + xBranch2' = down xBranch2 + in xSplit n tK xN xBranch1' xBranch2' + + -- Boilerplate -------------------------- XVar{} -> xx XCon{} -> xx @@ -449,17 +471,38 @@ XWitness{} -> xx + +------------------------------------------------------------------------------- +type TypeF = Type Name +type ExpF = Exp () Name + xNatOfRateNat :: Type Name -> Exp () Name -> Exp () Name xNatOfRateNat tK xR = xApps () - (xVarOpFlow OpFlowNatOfRateNat) - [XType tK, xR] + (xVarOpConcrete OpConcreteNatOfRateNat) + [XType () tK, xR] -xVarOpFlow :: OpFlow -> Exp () Name -xVarOpFlow op - = XVar () (UPrim (NameOpFlow op) (typeOpFlow op)) +xVarOpConcrete :: OpConcrete -> Exp () Name +xVarOpConcrete op + = XVar () (UPrim (NameOpConcrete op) (typeOpConcrete op)) + +xSplit :: Int + -> TypeF + -> ExpF + -> ExpF -> ExpF -> ExpF +xSplit n tK xRN xDownFn xTailFn + = xApps () + (xVarOpControl $ OpControlSplit n) + [ XType () tK, xRN, xDownFn, xTailFn ] + + +xVarOpControl :: OpControl -> Exp () Name +xVarOpControl op + = XVar () (UPrim (NameOpControl op) (typeOpControl op)) + + ------------------------------------------------------------------------------- -- | Make the type of a loop result, -- given the types of the accumulators for that loop. @@ -484,7 +527,7 @@ [] -> xUnit a [x] -> x _ -> xApps a (XCon a (dcTupleN $ length tsAccs)) - ([XType t | t <- tsAccs] ++ xsAccs) + ([XType a t | t <- tsAccs] ++ xsAccs) -- | Call a loop, and unpack its result. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyrite (K) 2007-2013 The Disciplined Disciple Compiler Strike Force +Copyrite (K) 2007-2014 The Disciplined Disciple Compiler Strike Force All rights reversed. Permission is hereby granted, free of charge, to any person obtaining a copy @@ -13,18 +13,4 @@ The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - -------------------------------------------------------------------------------- -Under Australian law copyright is free and automatic. -By contributing to DDC authors grant all rights they have regarding their -contributions to the other members of the Disciplined Disciple Compiler Strike -Force, past, present and future, as well as placing their contributions under -the above license. - -Use "darcs show authors" to get a list of Strike Force members. - -------------------------------------------------------------------------------- -Redistributions of libraries in ./external are governed by their own licenses: - - - TinyPTC GNU Lesser General Public License - diff --git a/ddc-core-flow.cabal b/ddc-core-flow.cabal --- a/ddc-core-flow.cabal +++ b/ddc-core-flow.cabal @@ -1,5 +1,5 @@ Name: ddc-core-flow -Version: 0.3.2.1 +Version: 0.4.1.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -30,67 +30,78 @@ Library Build-Depends: - base == 4.6.*, + base >= 4.6 && < 4.8, + array >= 0.4 && < 0.6, deepseq == 1.3.*, containers == 0.5.*, - array == 0.4.*, transformers == 0.3.*, mtl == 2.1.*, - ddc-base == 0.3.2.*, - ddc-core == 0.3.2.*, - ddc-core-salt == 0.3.2.*, - ddc-core-simpl == 0.3.2.* + ddc-base == 0.4.1.*, + ddc-core == 0.4.1.*, + ddc-core-salt == 0.4.1.*, + ddc-core-simpl == 0.4.1.* Exposed-modules: - DDC.Core.Flow - DDC.Core.Flow.Profile - DDC.Core.Flow.Exp - DDC.Core.Flow.Compounds - DDC.Core.Flow.Env - DDC.Core.Flow.Context - - DDC.Core.Flow.Prim - - DDC.Core.Flow.Procedure - - DDC.Core.Flow.Process.Process DDC.Core.Flow.Process.Operator - DDC.Core.Flow.Process.Pretty - DDC.Core.Flow.Process + DDC.Core.Flow.Process.Process + DDC.Core.Flow.Transform.Rates.Constraints + DDC.Core.Flow.Transform.Rates.Fail + DDC.Core.Flow.Transform.Rates.Graph + DDC.Core.Flow.Transform.Rates.SeriesOfVector + + DDC.Core.Flow.Transform.Concretize + DDC.Core.Flow.Transform.Extract + DDC.Core.Flow.Transform.Melt DDC.Core.Flow.Transform.Schedule - DDC.Core.Flow.Transform.Prep DDC.Core.Flow.Transform.Slurp - DDC.Core.Flow.Transform.Extract - DDC.Core.Flow.Transform.Concretize DDC.Core.Flow.Transform.Thread DDC.Core.Flow.Transform.Wind + DDC.Core.Flow.Compounds + DDC.Core.Flow.Context + DDC.Core.Flow.Env + DDC.Core.Flow.Exp + DDC.Core.Flow.Lower + DDC.Core.Flow.Prim + DDC.Core.Flow.Procedure + DDC.Core.Flow.Process + DDC.Core.Flow.Profile + DDC.Core.Flow + Other-modules: + DDC.Core.Flow.Process.Pretty + DDC.Core.Flow.Prim.Base - DDC.Core.Flow.Prim.KiConFlow - DDC.Core.Flow.Prim.TyConFlow - DDC.Core.Flow.Prim.TyConPrim DDC.Core.Flow.Prim.DaConFlow DDC.Core.Flow.Prim.DaConPrim - DDC.Core.Flow.Prim.OpFlow - DDC.Core.Flow.Prim.OpLoop - DDC.Core.Flow.Prim.OpStore + DDC.Core.Flow.Prim.KiConFlow + DDC.Core.Flow.Prim.OpConcrete + DDC.Core.Flow.Prim.OpControl DDC.Core.Flow.Prim.OpPrim - - DDC.Core.Flow.Transform.Slurp.Operator - DDC.Core.Flow.Transform.Slurp.Alloc + DDC.Core.Flow.Prim.OpSeries + DDC.Core.Flow.Prim.OpStore + DDC.Core.Flow.Prim.OpVector + DDC.Core.Flow.Prim.TyConFlow + DDC.Core.Flow.Prim.TyConPrim - DDC.Core.Flow.Transform.Schedule.SeriesEnv + DDC.Core.Flow.Transform.Schedule.Base + DDC.Core.Flow.Transform.Schedule.Error + DDC.Core.Flow.Transform.Schedule.Kernel + DDC.Core.Flow.Transform.Schedule.Lifting DDC.Core.Flow.Transform.Schedule.Nest + DDC.Core.Flow.Transform.Schedule.Scalar - DDC.Core.Flow.Transform.Extract.Intersperse + DDC.Core.Flow.Transform.Slurp.Error + DDC.Core.Flow.Transform.Slurp.Operator GHC-options: + -Wall -fno-warn-orphans -fno-warn-missing-signatures + -fno-warn-missing-methods -fno-warn-unused-do-bind Extensions: @@ -102,4 +113,5 @@ ParallelListComp DeriveDataTypeable ViewPatterns + FlexibleInstances