ddc-core-flow 0.3.2.1 → 0.4.1.1
raw patch · 50 files changed
+4805/−1718 lines, 50 filesdep ~arraydep ~basedep ~ddc-base
Dependency ranges changed: array, base, ddc-base, ddc-core, ddc-core-salt, ddc-core-simpl
Files
- DDC/Core/Flow.hs +17/−0
- DDC/Core/Flow/Compounds.hs +33/−11
- DDC/Core/Flow/Context.hs +9/−1
- DDC/Core/Flow/Env.hs +38/−29
- DDC/Core/Flow/Exp.hs +2/−0
- DDC/Core/Flow/Lower.hs +292/−0
- DDC/Core/Flow/Prim.hs +77/−34
- DDC/Core/Flow/Prim/Base.hs +140/−51
- DDC/Core/Flow/Prim/DaConPrim.hs +9/−9
- DDC/Core/Flow/Prim/OpConcrete.hs +191/−0
- DDC/Core/Flow/Prim/OpControl.hs +132/−0
- DDC/Core/Flow/Prim/OpFlow.hs +0/−252
- DDC/Core/Flow/Prim/OpLoop.hs +0/−84
- DDC/Core/Flow/Prim/OpPrim.hs +73/−1
- DDC/Core/Flow/Prim/OpSeries.hs +261/−0
- DDC/Core/Flow/Prim/OpStore.hs +102/−51
- DDC/Core/Flow/Prim/OpVector.hs +125/−0
- DDC/Core/Flow/Prim/TyConFlow.hs +77/−2
- DDC/Core/Flow/Prim/TyConPrim.hs +23/−3
- DDC/Core/Flow/Procedure.hs +25/−14
- DDC/Core/Flow/Process.hs +2/−0
- DDC/Core/Flow/Process/Operator.hs +137/−48
- DDC/Core/Flow/Process/Pretty.hs +59/−18
- DDC/Core/Flow/Process/Process.hs +14/−19
- DDC/Core/Flow/Profile.hs +3/−5
- DDC/Core/Flow/Transform/Concretize.hs +49/−8
- DDC/Core/Flow/Transform/Extract.hs +55/−29
- DDC/Core/Flow/Transform/Extract/Intersperse.hs +0/−53
- DDC/Core/Flow/Transform/Melt.hs +169/−0
- DDC/Core/Flow/Transform/Prep.hs +0/−169
- DDC/Core/Flow/Transform/Rates/Constraints.hs +351/−0
- DDC/Core/Flow/Transform/Rates/Fail.hs +50/−0
- DDC/Core/Flow/Transform/Rates/Graph.hs +170/−0
- DDC/Core/Flow/Transform/Rates/SeriesOfVector.hs +482/−0
- DDC/Core/Flow/Transform/Schedule.hs +8/−247
- DDC/Core/Flow/Transform/Schedule/Base.hs +86/−0
- DDC/Core/Flow/Transform/Schedule/Error.hs +76/−0
- DDC/Core/Flow/Transform/Schedule/Kernel.hs +330/−0
- DDC/Core/Flow/Transform/Schedule/Lifting.hs +129/−0
- DDC/Core/Flow/Transform/Schedule/Nest.hs +176/−100
- DDC/Core/Flow/Transform/Schedule/Scalar.hs +330/−0
- DDC/Core/Flow/Transform/Schedule/SeriesEnv.hs +0/−157
- DDC/Core/Flow/Transform/Slurp.hs +181/−96
- DDC/Core/Flow/Transform/Slurp/Alloc.hs +0/−41
- DDC/Core/Flow/Transform/Slurp/Error.hs +33/−0
- DDC/Core/Flow/Transform/Slurp/Operator.hs +106/−47
- DDC/Core/Flow/Transform/Thread.hs +69/−66
- DDC/Core/Flow/Transform/Wind.hs +66/−23
- LICENSE +1/−15
- ddc-core-flow.cabal +47/−35
DDC/Core/Flow.hs view
@@ -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
DDC/Core/Flow/Compounds.hs view
@@ -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
DDC/Core/Flow/Context.hs view
@@ -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)
DDC/Core/Flow/Env.hs view
@@ -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
DDC/Core/Flow/Exp.hs view
@@ -33,3 +33,5 @@ type BoundF = Bound Name type BindF = Bind Name++
+ DDC/Core/Flow/Lower.hs view
@@ -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+
DDC/Core/Flow/Prim.hs view
@@ -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
DDC/Core/Flow/Prim/Base.hs view
@@ -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)
DDC/Core/Flow/Prim/DaConPrim.hs view
@@ -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))
+ DDC/Core/Flow/Prim/OpConcrete.hs view
@@ -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))+
+ DDC/Core/Flow/Prim/OpControl.hs view
@@ -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))+
− DDC/Core/Flow/Prim/OpFlow.hs
@@ -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))-
− DDC/Core/Flow/Prim/OpLoop.hs
@@ -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))
DDC/Core/Flow/Prim/OpPrim.hs view
@@ -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))+
+ DDC/Core/Flow/Prim/OpSeries.hs view
@@ -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
DDC/Core/Flow/Prim/OpStore.hs view
@@ -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 ----------------------------------------------------------------------
+ DDC/Core/Flow/Prim/OpVector.hs view
@@ -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+
DDC/Core/Flow/Prim/TyConFlow.hs view
@@ -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 ----------------------------------------------------------------------
DDC/Core/Flow/Prim/TyConPrim.hs view
@@ -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
DDC/Core/Flow/Procedure.hs view
@@ -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-
DDC/Core/Flow/Process.hs view
@@ -1,6 +1,8 @@ module DDC.Core.Flow.Process ( Process (..)+ , typeOfProcess+ , Operator (..)) where import DDC.Core.Flow.Process.Process
DDC/Core/Flow/Process/Operator.hs view
@@ -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
DDC/Core/Flow/Process/Pretty.hs view
@@ -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) ]
DDC/Core/Flow/Process/Process.hs view
@@ -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
DDC/Core/Flow/Profile.hs view
@@ -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
DDC/Core/Flow/Transform/Concretize.hs view
@@ -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
DDC/Core/Flow/Transform/Extract.hs view
@@ -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) ]
− DDC/Core/Flow/Transform/Extract/Intersperse.hs
@@ -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)))-
+ DDC/Core/Flow/Transform/Melt.hs view
@@ -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)+
− DDC/Core/Flow/Transform/Prep.hs
@@ -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-
+ DDC/Core/Flow/Transform/Rates/Constraints.hs view
@@ -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!+-}+
+ DDC/Core/Flow/Transform/Rates/Fail.hs view
@@ -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)+
+ DDC/Core/Flow/Transform/Rates/Graph.hs view
@@ -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)++
+ DDC/Core/Flow/Transform/Rates/SeriesOfVector.hs view
@@ -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] ]++-}
DDC/Core/Flow/Transform/Schedule.hs view
@@ -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
+ DDC/Core/Flow/Transform/Schedule/Base.hs view
@@ -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
+ DDC/Core/Flow/Transform/Schedule/Error.hs view
@@ -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 ]+
+ DDC/Core/Flow/Transform/Schedule/Kernel.hs view
@@ -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)+
+ DDC/Core/Flow/Transform/Schedule/Lifting.hs view
@@ -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+
DDC/Core/Flow/Transform/Schedule/Nest.hs view
@@ -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
+ DDC/Core/Flow/Transform/Schedule/Scalar.hs view
@@ -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+
− DDC/Core/Flow/Transform/Schedule/SeriesEnv.hs
@@ -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-
DDC/Core/Flow/Transform/Slurp.hs view
@@ -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)
− DDC/Core/Flow/Transform/Slurp/Alloc.hs
@@ -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
+ DDC/Core/Flow/Transform/Slurp/Error.hs view
@@ -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) ]
DDC/Core/Flow/Transform/Slurp/Operator.hs view
@@ -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
DDC/Core/Flow/Transform/Thread.hs view
@@ -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
DDC/Core/Flow/Transform/Wind.hs view
@@ -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.
LICENSE view
@@ -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-
ddc-core-flow.cabal view
@@ -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