ddc-core-flow (empty) → 0.3.2.1
raw patch · 37 files changed
+4312/−0 lines, 37 filesdep +arraydep +basedep +containerssetup-changed
Dependencies added: array, base, containers, ddc-base, ddc-core, ddc-core-salt, ddc-core-simpl, deepseq, mtl, transformers
Files
- DDC/Core/Flow.hs +25/−0
- DDC/Core/Flow/Compounds.hs +45/−0
- DDC/Core/Flow/Context.hs +21/−0
- DDC/Core/Flow/Env.hs +140/−0
- DDC/Core/Flow/Exp.hs +35/−0
- DDC/Core/Flow/Prim.hs +181/−0
- DDC/Core/Flow/Prim/Base.hs +199/−0
- DDC/Core/Flow/Prim/DaConFlow.hs +43/−0
- DDC/Core/Flow/Prim/DaConPrim.hs +63/−0
- DDC/Core/Flow/Prim/KiConFlow.hs +31/−0
- DDC/Core/Flow/Prim/OpFlow.hs +252/−0
- DDC/Core/Flow/Prim/OpLoop.hs +84/−0
- DDC/Core/Flow/Prim/OpPrim.hs +53/−0
- DDC/Core/Flow/Prim/OpStore.hs +183/−0
- DDC/Core/Flow/Prim/TyConFlow.hs +132/−0
- DDC/Core/Flow/Prim/TyConPrim.hs +57/−0
- DDC/Core/Flow/Procedure.hs +161/−0
- DDC/Core/Flow/Process.hs +8/−0
- DDC/Core/Flow/Process/Operator.hs +123/−0
- DDC/Core/Flow/Process/Pretty.hs +47/−0
- DDC/Core/Flow/Process/Process.hs +55/−0
- DDC/Core/Flow/Profile.hs +100/−0
- DDC/Core/Flow/Transform/Concretize.hs +85/−0
- DDC/Core/Flow/Transform/Extract.hs +189/−0
- DDC/Core/Flow/Transform/Extract/Intersperse.hs +53/−0
- DDC/Core/Flow/Transform/Prep.hs +169/−0
- DDC/Core/Flow/Transform/Schedule.hs +252/−0
- DDC/Core/Flow/Transform/Schedule/Nest.hs +177/−0
- DDC/Core/Flow/Transform/Schedule/SeriesEnv.hs +157/−0
- DDC/Core/Flow/Transform/Slurp.hs +199/−0
- DDC/Core/Flow/Transform/Slurp/Alloc.hs +41/−0
- DDC/Core/Flow/Transform/Slurp/Operator.hs +102/−0
- DDC/Core/Flow/Transform/Thread.hs +203/−0
- DDC/Core/Flow/Transform/Wind.hs +510/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- ddc-core-flow.cabal +105/−0
+ DDC/Core/Flow.hs view
@@ -0,0 +1,25 @@++-- | Disciple Core Flow is a Domain Specific Language (DSL) for writing first+-- order data flow programs.+-- +module DDC.Core.Flow+ ( -- * Language profile+ profile++ -- * Names+ , Name (..)+ , TyConFlow (..)+ , PrimTyCon (..)+ , PrimArith (..)+ , PrimCast (..)++ -- * Name Parsing+ , readName++ -- * Program Lexing+ , lexModuleString+ , lexExpString)++where+import DDC.Core.Flow.Prim+import DDC.Core.Flow.Profile
+ DDC/Core/Flow/Compounds.hs view
@@ -0,0 +1,45 @@++-- | Short-hands for constructing compound expressions.+module DDC.Core.Flow.Compounds+ ( module DDC.Core.Compounds.Simple++ -- * Fragment specific kinds+ , kRate++ -- * Fragment specific types+ , tTuple1, tTuple2, tTupleN+ , tVector, tSeries, tSegd, tSel1, tSel2, tRef, tWorld+ , tRateNat++ -- * Primtiive types+ , tVoid, tBool, tNat, tInt, tWord++ -- * Primitive literals and data constructors+ , xBool, dcBool+ , xNat, dcNat+ , dcTuple1+ , xTuple2, dcTuple2+ , dcTupleN++ -- * Flow operators+ , xRateOfSeries+ , xNatOfRateNat++ -- * Loop operators+ , xLoopLoopN+ , xLoopGuard++ -- * Store operators+ , xNew, xRead, xWrite+ , xNewVector, xReadVector, xWriteVector, xNewVectorR, xNewVectorN+ , xSliceVector+ , xNext)+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.OpStore+import DDC.Core.Compounds.Simple
+ DDC/Core/Flow/Context.hs view
@@ -0,0 +1,21 @@++module DDC.Core.Flow.Context+ (Context (..))+where+import DDC.Type.Exp+import DDC.Core.Flow.Prim++data Context+ -- | A top-level context associated with a rate that is a parameter+ -- of the process. This context isn't created by the process itself.+ = ContextRate+ { contextRate :: Type Name }++ -- | A nested context created by a mkSel function.+ | ContextSelect+ { contextOuterRate :: Type Name+ , contextInnerRate :: Type Name+ , contextFlags :: Bound Name+ , contextSelector :: Bind Name }+ deriving (Show, Eq)+
+ DDC/Core/Flow/Env.hs view
@@ -0,0 +1,140 @@++module DDC.Core.Flow.Env+ ( primDataDefs+ , primSortEnv+ , primKindEnv+ , primTypeEnv)+where+import DDC.Core.Flow.Prim+import DDC.Core.Flow.Compounds+import DDC.Type.DataDef+import DDC.Type.Exp+import DDC.Type.Env (Env)+import qualified DDC.Type.Env as Env+++-- DataDefs -------------------------------------------------------------------+-- | Data type definitions +--+-- > Type Constructors+-- > ---- ------------------------------+-- > Bool# True# False#+-- > Nat# 0# 1# 2# ...+-- > Int# ... -2i# -1i# 0i# 1i# 2i# ...+-- > Tag# (none, convert from Nat#)+-- > Word{8,16,32,64}# 42w8# 123w64# ...+-- > Float{32,64}# (none, convert from Int#)+-- >+-- > Tuple{2-32} (T{2-32})+-- > Vector (none, abstract)+-- > Series (none, abstract)+-- +primDataDefs :: DataDefs Name+primDataDefs+ = fromListDataDefs+ -- Primitive -----------------------------------------------+ $ -- Bool#+ [ DataDef (NamePrimTyCon PrimTyConBool) + [] + (Just [ (NameLitBool True, []) + , (NameLitBool False, []) ])++ -- Nat#+ , DataDef (NamePrimTyCon PrimTyConNat) [] Nothing++ -- Int#+ , DataDef (NamePrimTyCon PrimTyConInt) [] Nothing++ -- WordN#+ , DataDef (NamePrimTyCon (PrimTyConWord 64)) [] Nothing+ , DataDef (NamePrimTyCon (PrimTyConWord 32)) [] Nothing+ , DataDef (NamePrimTyCon (PrimTyConWord 16)) [] Nothing+ , DataDef (NamePrimTyCon (PrimTyConWord 8)) [] Nothing+++ -- Flow -----------------------------------------------------++ -- Vector+ , DataDef+ (NameTyConFlow TyConFlowVector)+ [kRate, kData]+ (Just [])++ -- Series+ , DataDef+ (NameTyConFlow TyConFlowSeries)+ [kRate, kData]+ (Just [])+ ]++ -- Tuple+ -- Hard-code maximum tuple arity to 32.+ ++ [ makeTupleDataDef arity | arity <- [2..32] ]+++-- | Make a tuple data def for the given tuple arity.+makeTupleDataDef :: Int -> DataDef Name+makeTupleDataDef n+ = DataDef+ (NameTyConFlow (TyConFlowTuple n))+ (replicate n kData)+ (Just [ ( NameDaConFlow (DaConFlowTuple n)+ , (reverse [tIx kData i | i <- [0..n - 1]]))])+++-- Sorts ---------------------------------------------------------------------+-- | Sort environment containing sorts of primitive kinds.+primSortEnv :: Env Name+primSortEnv = Env.setPrimFun sortOfPrimName Env.empty+++-- | Take the sort of a primitive kind name.+sortOfPrimName :: Name -> Maybe (Sort Name)+sortOfPrimName _ = Nothing+++-- Kinds ----------------------------------------------------------------------+-- | Kind environment containing kinds of primitive data types.+primKindEnv :: Env Name+primKindEnv = Env.setPrimFun kindOfPrimName Env.empty+++-- | Take the kind of a primitive name.+--+-- Returns `Nothing` if the name isn't primitive. +--+kindOfPrimName :: Name -> Maybe (Kind Name)+kindOfPrimName nn+ = case nn of+ NameKiConFlow KiConFlowRate -> Just sProp+ NameTyConFlow tc -> Just $ kindTyConFlow tc+ NamePrimTyCon tc -> Just $ kindPrimTyCon tc+ _ -> Nothing+++-- Types ----------------------------------------------------------------------+-- | Type environment containing types of primitive operators.+primTypeEnv :: Env Name+primTypeEnv = Env.setPrimFun typeOfPrimName Env.empty+++-- | Take the type of a name,+-- or `Nothing` if this is not a value name.+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++ NamePrimCast p -> Just $ typePrimCast p+ NamePrimArith p -> Just $ typePrimArith p++ NameLitBool _ -> Just $ tBool+ NameLitNat _ -> Just $ tNat+ NameLitInt _ -> Just $ tInt+ NameLitWord _ bits -> Just $ tWord bits++ _ -> Nothing+
+ DDC/Core/Flow/Exp.hs view
@@ -0,0 +1,35 @@++module DDC.Core.Flow.Exp+ ( module DDC.Core.Exp.Simple + , KindEnvF, TypeEnvF+ , TypeF+ , ModuleF+ , ExpF+ , CastF+ , LetsF+ , AltF+ , PatF+ , WitnessF+ , BoundF+ , BindF)+where+import DDC.Core.Module+import DDC.Core.Flow.Prim+import DDC.Core.Exp.Simple+import DDC.Type.Env (Env)++type KindEnvF = Env Name+type TypeEnvF = Env Name++type TypeF = Type Name++type ModuleF = Module () Name+type ExpF = Exp () Name+type CastF = Cast () Name+type LetsF = Lets () Name+type AltF = Alt () Name+type PatF = Pat Name+type WitnessF = Witness () Name++type BoundF = Bound Name+type BindF = Bind Name
+ DDC/Core/Flow/Prim.hs view
@@ -0,0 +1,181 @@++module DDC.Core.Flow.Prim+ ( -- * Names and lexing+ Name (..)+ , readName++ -- * Fragment specific kind constructors+ , KiConFlow (..)+ , readKiConFlow++ -- * Fragment specific type constructors+ , TyConFlow (..)+ , readTyConFlow+ , kindTyConFlow++ -- * Fragment specific data constructors+ , DaConFlow (..)+ , readDaConFlow+ , typeDaConFlow++ -- * Flow operators+ , OpFlow (..)+ , readOpFlow+ , typeOpFlow++ -- * Loop operators+ , OpLoop (..)+ , readOpLoop+ , typeOpLoop++ -- * Store operators+ , OpStore (..)+ , readOpStore+ , typeOpStore++ -- * Primitive type constructors+ , PrimTyCon (..)+ , kindPrimTyCon++ -- * Primitive arithmetic operators+ , PrimArith (..)+ , typePrimArith++ -- * Casting between primitive types+ , PrimCast (..)+ , typePrimCast)+where+import DDC.Core.Flow.Prim.Base+import DDC.Core.Flow.Prim.KiConFlow+import DDC.Core.Flow.Prim.TyConFlow+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.OpStore+import DDC.Core.Flow.Prim.OpPrim++import DDC.Core.Salt.Name + ( readPrimTyCon+ , readPrimCast+ , readPrimArith+ , readLitPrimNat+ , readLitPrimInt+ , readLitPrimWordOfBits)++import DDC.Base.Pretty+import Control.DeepSeq+import Data.Char +++instance NFData Name where+ rnf nn+ = case nn of+ NameVar s -> rnf s+ NameVarMod n s -> rnf n `seq` rnf s+ NameCon s -> rnf s++ NameKiConFlow con -> rnf con+ NameTyConFlow con -> rnf con+ NameDaConFlow con -> rnf con+ NameOpFlow op -> rnf op+ NameOpLoop op -> rnf op+ NameOpStore op -> rnf op++ NamePrimTyCon con -> rnf con+ NamePrimArith con -> rnf con+ NamePrimCast c -> rnf c++ NameLitBool b -> rnf b+ NameLitNat n -> rnf n+ NameLitInt i -> rnf i+ NameLitWord i bits -> rnf i `seq` rnf bits+++instance Pretty Name where+ ppr nn+ = case nn of+ NameVar s -> text s+ NameVarMod n s -> ppr n <> text "$" <> text s+ NameCon c -> text c++ NameKiConFlow con -> ppr con+ NameTyConFlow con -> ppr con+ NameDaConFlow con -> ppr con+ NameOpFlow op -> ppr op+ NameOpLoop op -> ppr op+ NameOpStore op -> ppr op++ NamePrimTyCon tc -> ppr tc+ NamePrimArith 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 "#"+++-- | 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++ -- Primitive names.+ | Just p <- readPrimTyCon str = Just $ NamePrimTyCon p+ | Just p <- readPrimArith str = Just $ NamePrimArith p+ | Just p <- readPrimCast str = Just $ NamePrimCast p++ -- Literal Bools+ | str == "True#" = Just $ NameLitBool True+ | str == "False#" = Just $ NameLitBool False++ -- Literal Nat+ | Just val <- readLitPrimNat str+ = Just $ NameLitNat val++ -- Literal Ints+ | Just val <- readLitPrimInt str+ = Just $ NameLitInt val++ -- Literal Words+ | Just (val, bits) <- readLitPrimWordOfBits str+ , elem bits [8, 16, 32, 64]+ = Just $ NameLitWord val bits++ -- Variables.+ | c : _ <- str+ , isLower c+ , Just (str1, strMod) <- splitModString str+ , Just n <- readName str1+ = Just $ NameVarMod n strMod++ | c : _ <- str+ , isLower c + = Just $ NameVar str++ -- Constructors.+ | c : _ <- str+ , isUpper c+ = Just $ NameCon str++ | otherwise+ = Nothing+++-- | Strip a `...$thing` modifier from a name.+splitModString :: String -> Maybe (String, String)+splitModString str+ = case break (== '$') (reverse str) of+ (_, "") -> Nothing+ ("", _) -> Nothing+ (s2, _ : s1) -> Just (reverse s1, reverse s2)+
+ DDC/Core/Flow/Prim/Base.hs view
@@ -0,0 +1,199 @@++module DDC.Core.Flow.Prim.Base+ ( Name (..)+ , KiConFlow (..)+ , TyConFlow (..)+ , DaConFlow (..)+ , OpFlow (..)+ , OpLoop (..)+ , OpStore (..)+ , PrimTyCon (..)+ , PrimArith (..)+ , PrimCast (..))+where+import Data.Typeable+import DDC.Core.Salt.Name + ( PrimTyCon (..)+ , PrimArith (..)+ , PrimCast (..))+++-- | Names of things used in Disciple Core Flow.+data Name+ -- | User defined variables.+ = NameVar String++ -- | A name generated by modifying some other name `name$mod`+ | NameVarMod Name String++ -- | A user defined constructor.+ | NameCon String++ -- Fragment specific primops -----------+ -- | Fragment specific kind constructors.+ | NameKiConFlow KiConFlow++ -- | Fragment specific type constructors.+ | NameTyConFlow TyConFlow++ -- | Fragment specific data constructors.+ | NameDaConFlow DaConFlow++ -- | Flow operators.+ | NameOpFlow OpFlow++ -- | Loop operators.+ | NameOpLoop OpLoop++ -- | Store operators.+ | NameOpStore OpStore+++ -- Machine primitives ------------------+ -- | A primitive type constructor.+ | NamePrimTyCon PrimTyCon++ -- | Primitive arithmetic, logic, comparison and bit-wise operators.+ | NamePrimArith PrimArith++ -- | Primitive casting between numeric types.+ | NamePrimCast PrimCast+++ -- Literals -----------------------------+ -- | A boolean literal.+ | NameLitBool Bool++ -- | A natural literal.+ | NameLitNat Integer++ -- | An integer literal.+ | NameLitInt Integer++ -- | A word literal.+ | NameLitWord Integer Int+ deriving (Eq, Ord, Show, Typeable)+++-- | Fragment specific kind constructors.+data KiConFlow+ = KiConFlowRate+ deriving (Eq, Ord, Show)+++-- | Fragment specific type constructors.+data TyConFlow+ -- | @TupleN#@ constructor. Tuples.+ = TyConFlowTuple Int ++ -- | @Vector#@ constructor. Vectors. + | TyConFlowVector++ -- | @Series#@ constructor. Series types.+ | TyConFlowSeries++ -- | @Segd#@ constructor. Segment Descriptors.+ | TyConFlowSegd++ -- | @SelN#@ constructor. Selectors.+ | TyConFlowSel Int++ -- | @Ref#@ constructor. References.+ | TyConFlowRef ++ -- | @World#@ constructor. State token used when converting to GHC core.+ | TyConFlowWorld++ -- | @RateNat#@ constructor. Naturals witnessing a type-level Rate. + | TyConFlowRateNat+ deriving (Eq, Ord, Show)+++-- | Primitive data constructors.+data DaConFlow+ -- | @TN@ data constructor.+ = DaConFlowTuple Int + deriving (Eq, Ord, Show)+++-- | Flow operators.+data OpFlow+ -- series conversions.+ = OpFlowVectorOfSeries+ | OpFlowRateOfSeries+ | OpFlowNatOfRateNat++ -- selectors+ | OpFlowMkSel Int++ -- maps+ | OpFlowMap Int++ -- replicates+ | OpFlowRep+ | OpFlowReps++ -- folds+ | OpFlowFold+ | OpFlowFoldIndex+ | OpFlowFolds++ -- unfolds+ | OpFlowUnfold+ | OpFlowUnfolds++ -- split/combine+ | OpFlowSplit Int+ | OpFlowCombine Int++ -- packing+ | OpFlowPack+ deriving (Eq, Ord, Show)+++-- | Loop operators.+data OpLoop+ = OpLoopLoop+ | OpLoopLoopN+ | OpLoopGuard+ deriving (Eq, Ord, Show)+++-- | Store operators.+data OpStore+ -- Assignables ----------------+ -- | Allocate a new reference.+ = OpStoreNew ++ -- | Read from a reference.+ | OpStoreRead++ -- | Write to a reference.+ | OpStoreWrite+++ -- Vectors --------------------+ -- | Allocate a new vector (taking a @Nat@ for the length)+ | OpStoreNewVector++ -- | Allocate a new vector (taking a @Rate@ for the length)+ | OpStoreNewVectorR ++ -- | Allocate a new vector (taking a @RateNat@ for the length)+ | OpStoreNewVectorN ++ -- | Read from a vector.+ | OpStoreReadVector ++ -- | Write to a vector.+ | OpStoreWriteVector++ -- | Slice after a pack/filter (taking a @Nat@ for new length)+ | OpStoreSliceVector +++ -- Streams --------------------+ -- | Take the next element from a series.+ | OpStoreNext+ deriving (Eq, Ord, Show)+
+ DDC/Core/Flow/Prim/DaConFlow.hs view
@@ -0,0 +1,43 @@++module DDC.Core.Flow.Prim.DaConFlow+ ( readDaConFlow+ , typeDaConFlow)+where+import DDC.Core.Flow.Prim.TyConFlow+import DDC.Core.Flow.Prim.Base+import DDC.Core.Exp.Simple+import DDC.Core.Compounds.Simple+import DDC.Base.Pretty+import Data.List+import Data.Char+import Control.DeepSeq+++instance NFData DaConFlow++instance Pretty DaConFlow where+ ppr dc+ = case dc of+ DaConFlowTuple n+ -> text "T" <> int n <> text "#"+++-- | Read a data constructor name.+readDaConFlow :: String -> Maybe DaConFlow+readDaConFlow str+ | Just rest <- stripPrefix "T" str+ , (ds, "#") <- span isDigit rest+ , not $ null ds+ , arity <- read ds+ = Just $ DaConFlowTuple arity++ | otherwise+ = Nothing+++-- | Yield the type of a data constructor.+typeDaConFlow :: DaConFlow -> Type Name+typeDaConFlow (DaConFlowTuple n)+ = tForalls (replicate n kData)+ $ \args -> foldr tFun (tTupleN args) args+
+ DDC/Core/Flow/Prim/DaConPrim.hs view
@@ -0,0 +1,63 @@++module DDC.Core.Flow.Prim.DaConPrim+ ( xBool, dcBool+ , xNat, dcNat+ , dcTuple1+ , xTuple2, dcTuple2+ , dcTupleN)+where+import DDC.Core.Flow.Prim.TyConPrim+import DDC.Core.Flow.Prim.DaConFlow+import DDC.Core.Flow.Prim.Base+import DDC.Core.Compounds.Simple+import DDC.Core.Exp.Simple+++-- | A literal @Bool#@+xBool :: Bool -> Exp a Name+xBool b = XCon (mkDaConAlg (NameLitBool b) tBool)+++-- | A literal @Bool#@ data constructor.+dcBool :: Bool -> DaCon Name+dcBool b = mkDaConAlg (NameLitBool b) tBool+++-- | A literal @Nat#@+xNat :: Integer -> Exp a Name+xNat i = XCon (dcNat i)+++-- | A Literal @Nat#@ data constructor.+dcNat :: Integer -> DaCon Name+dcNat i = mkDaConAlg (NameLitInt i) tNat+++-- | Data constructor for @Tuple1#@+dcTuple1 :: DaCon Name+dcTuple1 = mkDaConAlg (NameDaConFlow (DaConFlowTuple 1))+ $ typeDaConFlow (DaConFlowTuple 1)+++-- | Construct a @Tuple2#@+xTuple2 :: Type Name -> Type Name + -> Exp a Name -> Exp a Name + -> Exp a Name++xTuple2 t1 t2 x1 x2+ = xApps (XCon dcTuple2) + [XType t1, XType t2, x1, x2]+++-- | Data constructor for @Tuple2#@+dcTuple2 :: DaCon Name+dcTuple2 = mkDaConAlg (NameDaConFlow (DaConFlowTuple 2))+ $ typeDaConFlow (DaConFlowTuple 2)+++-- | Data constructor for n-tuples+dcTupleN :: Int -> DaCon Name+dcTupleN n+ = mkDaConAlg (NameDaConFlow (DaConFlowTuple n))+ $ typeDaConFlow (DaConFlowTuple n)+
+ DDC/Core/Flow/Prim/KiConFlow.hs view
@@ -0,0 +1,31 @@++module DDC.Core.Flow.Prim.KiConFlow+ ( readKiConFlow+ , kRate)+where+import DDC.Core.Flow.Prim.Base+import DDC.Core.Compounds+import DDC.Core.Exp.Simple+import DDC.Base.Pretty+import Control.DeepSeq+++instance NFData KiConFlow+++instance Pretty KiConFlow where+ ppr con+ = case con of+ KiConFlowRate -> text "Rate"+++-- | Read a kind constructor name.+readKiConFlow :: String -> Maybe KiConFlow+readKiConFlow str+ = case str of+ "Rate" -> Just $ KiConFlowRate+ _ -> Nothing+++-- Compounds ------------------------------------------------------------------+kRate = TCon (TyConBound (UPrim (NameKiConFlow KiConFlowRate) sProp) sProp)
+ DDC/Core/Flow/Prim/OpFlow.hs view
@@ -0,0 +1,252 @@++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 view
@@ -0,0 +1,84 @@++-- | 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
@@ -0,0 +1,53 @@++module DDC.Core.Flow.Prim.OpPrim+ ( typePrimCast+ , typePrimArith)+where+import DDC.Core.Flow.Prim.TyConPrim+import DDC.Core.Flow.Prim.Base+import DDC.Core.Compounds.Simple+import DDC.Core.Exp.Simple+++-- | Take the type of a primitive cast.+typePrimCast :: PrimCast -> Type Name+typePrimCast cc+ = case cc of+ PrimCastPromote+ -> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFun` t1++ PrimCastTruncate+ -> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFun` t1+++-- | Take the type of a primitive arithmetic operator.+typePrimArith :: PrimArith -> Type Name+typePrimArith op+ = case op of+ -- Numeric+ PrimArithNeg -> tForall kData $ \t -> t `tFun` t+ PrimArithAdd -> tForall kData $ \t -> t `tFun` t `tFun` t+ PrimArithSub -> tForall kData $ \t -> t `tFun` t `tFun` t+ PrimArithMul -> tForall kData $ \t -> t `tFun` t `tFun` t+ PrimArithDiv -> tForall kData $ \t -> t `tFun` t `tFun` t+ PrimArithMod -> tForall kData $ \t -> t `tFun` t `tFun` t+ PrimArithRem -> tForall kData $ \t -> t `tFun` t `tFun` t++ -- Comparison+ PrimArithEq -> tForall kData $ \t -> t `tFun` t `tFun` tBool+ PrimArithNeq -> tForall kData $ \t -> t `tFun` t `tFun` tBool+ PrimArithGt -> tForall kData $ \t -> t `tFun` t `tFun` tBool+ PrimArithLt -> tForall kData $ \t -> t `tFun` t `tFun` tBool+ PrimArithLe -> tForall kData $ \t -> t `tFun` t `tFun` tBool+ PrimArithGe -> tForall kData $ \t -> t `tFun` t `tFun` tBool++ -- Boolean+ PrimArithAnd -> tBool `tFun` tBool `tFun` tBool+ PrimArithOr -> tBool `tFun` tBool `tFun` tBool++ -- Bitwise+ PrimArithShl -> tForall kData $ \t -> t `tFun` t `tFun` t+ PrimArithShr -> tForall kData $ \t -> t `tFun` t `tFun` t+ 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
+ DDC/Core/Flow/Prim/OpStore.hs view
@@ -0,0 +1,183 @@++module DDC.Core.Flow.Prim.OpStore+ ( OpStore (..)+ , readOpStore+ , typeOpStore+ , xNew, xRead, xWrite+ , xNewVector, xReadVector, xWriteVector, xNewVectorR, xNewVectorN+ , xSliceVector+ , xNext)+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+++instance NFData OpStore+++instance Pretty OpStore where+ ppr so+ = case so of+ -- Assignables.+ OpStoreNew -> text "new#"+ OpStoreRead -> text "read#"+ OpStoreWrite -> text "write#"++ -- Vectors.+ OpStoreNewVector -> text "newVector#"+ OpStoreNewVectorR -> text "newVectorR#"+ OpStoreNewVectorN -> text "newVectorN#"+ OpStoreReadVector -> text "readVector#"+ OpStoreWriteVector -> text "writeVector#"+ OpStoreSliceVector -> text "sliceVector#"++ -- Streams.+ OpStoreNext -> text "next#"+++-- | Read a store operator name.+readOpStore :: String -> Maybe OpStore+readOpStore str+ = case str of+ "new#" -> Just OpStoreNew+ "read#" -> Just OpStoreRead+ "write#" -> Just OpStoreWrite++ "newVector#" -> Just OpStoreNewVector+ "newVectorR#" -> Just OpStoreNewVectorR+ "newVectorN#" -> Just OpStoreNewVectorN+ "readVector#" -> Just OpStoreReadVector+ "writeVector#" -> Just OpStoreWriteVector+ "sliceVector#" -> Just OpStoreSliceVector++ "next#" -> Just OpStoreNext+ _ -> 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+ OpStoreNew+ -> tForall kData $ \tA -> tA `tFun` tRef tA++ -- read# :: [a : Data]. Ref# a -> a+ OpStoreRead+ -> tForall kData $ \tA -> tRef tA `tFun` tA++ -- write# :: [a : Data]. Ref# a -> a -> Unit+ OpStoreWrite+ -> tForall kData $ \tA -> tRef tA `tFun` tA `tFun` tUnit++ -- Arrays ---------------------+ -- newVector# :: [a : Data]. Nat -> Vector# a+ OpStoreNewVector+ -> tForall kData $ \tA -> tNat `tFun` tVector tA+ + -- newVectorR# :: [a : Data]. [k : Rate]. Vector# a+ OpStoreNewVectorR+ -> tForalls [kData, kRate] + $ \[tA, _] -> tVector tA+ + -- newVectorN# :: [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+ -> tForall kData + $ \tA -> tVector tA `tFun` tNat `tFun` tA++ -- writeVector# :: [a : Data]. Vector# a -> Nat# -> a -> Unit+ OpStoreWriteVector+ -> tForall kData + $ \tA -> tVector tA `tFun` tNat `tFun` tA `tFun` tUnit++ -- sliceVector# :: [a : Data]. Nat# -> Vector# a -> Vector# a+ OpStoreSliceVector+ -> tForall kData + $ \tA -> tNat `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+++-- Compounds ------------------------------------------------------------------+xNew :: Type Name -> Exp () Name -> Exp () Name+xNew t xV+ = xApps (xVarOpStore OpStoreNew)+ [XType t, xV ]+++xRead :: Type Name -> Exp () Name -> Exp () Name+xRead t xRef+ = xApps (xVarOpStore OpStoreRead)+ [XType t, xRef ]+++xWrite :: Type Name -> Exp () Name -> Exp () Name -> Exp () Name+xWrite t xRef xVal+ = xApps (xVarOpStore OpStoreWrite)+ [XType t, xRef, xVal ]+++xNewVector :: Type Name -> Exp () Name -> Exp () Name+xNewVector tElem xLen+ = xApps (xVarOpStore OpStoreNewVector)+ [XType tElem, xLen]+++xNewVectorR :: Type Name -> Type Name -> Exp () Name+xNewVectorR tElem tR+ = xApps (xVarOpStore OpStoreNewVectorR)+ [XType tElem, XType tR]+++xNewVectorN :: Type Name -> Type Name -> Exp () Name -> Exp () Name+xNewVectorN tA tR xRN+ = xApps (xVarOpStore OpStoreNewVectorN)+ [XType tA, XType tR, xRN]+++xReadVector :: Type Name -> Exp () Name -> Exp () Name -> Exp () Name+xReadVector t xArr xIx+ = xApps (xVarOpStore OpStoreReadVector)+ [XType t, xArr, xIx]+++xWriteVector :: Type Name -> Exp () Name -> Exp () Name -> Exp () Name -> Exp () Name+xWriteVector t xArr xIx xElem+ = xApps (xVarOpStore OpStoreWriteVector)+ [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]+++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]+++-- Utils ----------------------------------------------------------------------+xVarOpStore :: OpStore -> Exp () Name+xVarOpStore op+ = XVar (UPrim (NameOpStore op) (typeOpStore op))+
+ DDC/Core/Flow/Prim/TyConFlow.hs view
@@ -0,0 +1,132 @@++module DDC.Core.Flow.Prim.TyConFlow+ ( TyConFlow (..)+ , readTyConFlow+ , kindTyConFlow+ , tTuple1+ , tTuple2+ , tTupleN+ , tVector+ , tSeries+ , tSegd+ , tSel1+ , tSel2+ , tRef+ , tWorld+ , tRateNat)+where+import DDC.Core.Flow.Prim.KiConFlow+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 TyConFlow+++instance Pretty TyConFlow where+ ppr dc+ = case dc of+ TyConFlowTuple n -> text "Tuple" <> int n <> text "#"+ TyConFlowVector -> text "Vector#"+ TyConFlowSeries -> text "Series#"+ TyConFlowSegd -> text "Segd#"+ TyConFlowSel n -> text "Sel" <> int n <> text "#"+ TyConFlowRef -> text "Ref#"+ TyConFlowWorld -> text "World#"+ TyConFlowRateNat -> text "RateNat#"+++-- | Read a type constructor name.+readTyConFlow :: String -> Maybe TyConFlow+readTyConFlow str+ | Just rest <- stripPrefix "Tuple" str+ , (ds, "#") <- span isDigit rest+ , not $ null ds+ , arity <- read ds+ = Just $ TyConFlowTuple arity++ | otherwise+ = case str of+ "Vector#" -> Just $ TyConFlowVector+ "Series#" -> Just $ TyConFlowSeries+ "Segd#" -> Just $ TyConFlowSegd+ "Sel1#" -> Just $ TyConFlowSel 1+ "Ref#" -> Just $ TyConFlowRef+ "World#" -> Just $ TyConFlowWorld+ "RateNat#" -> Just $ TyConFlowRateNat+ _ -> Nothing+++-- Kinds ----------------------------------------------------------------------+-- | Yield the kind of a primitive type constructor.+kindTyConFlow :: TyConFlow -> Kind Name+kindTyConFlow tc+ = case tc of+ TyConFlowTuple n -> foldr kFun kData (replicate n kData)+ TyConFlowVector -> kData `kFun` kData+ TyConFlowSeries -> kRate `kFun` kData `kFun` kData+ TyConFlowSegd -> kRate `kFun` kRate `kFun` kData+ TyConFlowSel n -> foldr kFun kData (replicate (n + 1) kRate)+ TyConFlowRef -> kData `kFun` kData+ TyConFlowWorld -> kData+ TyConFlowRateNat -> kRate `kFun` kData+++-- Compounds ------------------------------------------------------------------+tTuple1 :: Type Name -> Type Name+tTuple1 tA = tApps (tConTyConFlow (TyConFlowTuple 1)) [tA]+++tTuple2 :: Type Name -> Type Name -> Type Name+tTuple2 tA tB = tApps (tConTyConFlow (TyConFlowTuple 2)) [tA, tB]+++tTupleN :: [Type Name] -> Type Name+tTupleN tys = tApps (tConTyConFlow (TyConFlowTuple (length tys))) tys+++tVector :: Type Name -> Type Name+tVector tA = tApps (tConTyConFlow TyConFlowVector) [tA]+++tSeries :: Type Name -> Type Name -> Type Name+tSeries tK tA = tApps (tConTyConFlow TyConFlowSeries) [tK, tA]+++tSegd :: Type Name -> Type Name -> Type Name+tSegd tK1 tK2 = tApps (tConTyConFlow TyConFlowSegd) [tK1, tK2]+++tSel1 :: Type Name -> Type Name -> Type Name+tSel1 tK1 tK2 = tApps (tConTyConFlow $ TyConFlowSel 1) [tK1, tK2]+++tSel2 :: Type Name -> Type Name -> Type Name -> Type Name+tSel2 tK1 tK2 tK3 = tApps (tConTyConFlow $ TyConFlowSel 2) [tK1, tK2, tK3]+++tRef :: Type Name -> Type Name+tRef tVal = tApp (tConTyConFlow $ TyConFlowRef) tVal+++tWorld :: Type Name+tWorld = tConTyConFlow TyConFlowWorld+++tRateNat :: Type Name -> Type Name+tRateNat tK = tApps (tConTyConFlow TyConFlowRateNat) [tK]+++-- Utils ----------------------------------------------------------------------+tConTyConFlow :: TyConFlow -> Type Name+tConTyConFlow tcf+ = let k = kindTyConFlow tcf+ u = UPrim (NameTyConFlow tcf) k+ tc = TyConBound u k+ in TCon tc+
+ DDC/Core/Flow/Prim/TyConPrim.hs view
@@ -0,0 +1,57 @@++module DDC.Core.Flow.Prim.TyConPrim + ( kindPrimTyCon+ , tVoid+ , tBool+ , tNat+ , tInt+ , tWord)+where+import DDC.Core.Flow.Prim.Base+import DDC.Core.Compounds.Simple+import DDC.Core.Exp.Simple+++-- | Yield the kind of a type constructor.+kindPrimTyCon :: PrimTyCon -> Kind Name+kindPrimTyCon tc+ = case tc of+ PrimTyConVoid -> kData+ PrimTyConPtr -> (kRegion `kFun` kData `kFun` kData)+ PrimTyConAddr -> kData+ PrimTyConBool -> kData+ PrimTyConNat -> kData+ PrimTyConInt -> kData+ PrimTyConWord _ -> kData+ PrimTyConFloat _ -> kData+ PrimTyConTag -> kData+ PrimTyConString -> kData+++-- Compounds ------------------------------------------------------------------+-- | Primitive `Void#` type.+tVoid = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConVoid) kData) kData)+++-- | Primitive `Bool#` type.+tBool :: Type Name+tBool = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConBool) kData) kData)+++-- | Primitive Nat# type.+tNat :: Type Name+tNat = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConInt) kData) kData)+++-- | Primitive `Int#` type.+tInt :: Type Name+tInt = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConInt) kData) kData)+++-- | Primitive `WordN#` type of the given width.+tWord :: Int -> Type Name+tWord bits + = TCon (TyConBound (UPrim (NamePrimTyCon (PrimTyConWord bits)) kData) kData)+++
+ DDC/Core/Flow/Procedure.hs view
@@ -0,0 +1,161 @@++-- | A `Procedure` is an abstract imperative loop nest. +-- The loops are represented as a separated loop anatomy, to make it+-- easy to incrementally build them from a data flow graph expressed+-- as a `Process`.+--+module DDC.Core.Flow.Procedure+ ( Procedure (..)+ , Nest (..)+ , Context (..)+ , StmtStart (..)+ , StmtBody (..)+ , StmtEnd (..))+where+import DDC.Core.Flow.Exp+import DDC.Core.Flow.Prim+import DDC.Core.Flow.Context+import Data.Monoid+++-- | An imperative procedure made up of some loops.+data Procedure+ = Procedure+ { procedureName :: Name+ , procedureParamTypes :: [BindF]+ , procedureParamValues :: [BindF]+ , procedureNest :: Nest+ , procedureStmts :: [LetsF]+ , procedureResult :: ExpF+ , procedureResultType :: TypeF }+++-- | A loop nest.+data Nest+ = NestEmpty++ | NestList+ { nestList :: [Nest]}++ | NestLoop+ { nestRate :: Type Name+ , nestStart :: [StmtStart]+ , nestBody :: [StmtBody]+ , nestInner :: Nest+ , nestEnd :: [StmtEnd] + , nestResult :: Exp () Name }++ | NestIf+ { nestOuterRate :: Type Name+ , nestInnerRate :: Type Name+ , nestFlags :: Bound Name+ , nestBody :: [StmtBody] + , nestInner :: Nest }+ deriving Show+++instance Monoid Nest where+ mempty = NestEmpty++ mappend n1 n2+ = case (n1, n2) of+ (NestEmpty, _) -> n2+ (_, NestEmpty) -> n1+ (NestList ns1, NestList ns2) -> NestList (ns1 ++ ns2)+ (NestList ns1, _) -> NestList (ns1 ++ [n2])+ (_, NestList ns2) -> NestList (n1 : ns2)+ (_, _) -> NestList [n1, n2]+++-- | Statements that can appear at the start of a loop.+-- These initialise accumulators.+data StmtStart+ -- Allocate a new vector.+ = StartVecNew+ { startVecNewName :: Name+ , startVecNewElemType :: Type Name+ , startVecNewRate :: Type Name }++ -- Inititlise a new accumulator.+ | StartAcc + { startAccName :: Name+ , startAccType :: Type Name+ , startAccExp :: Exp () Name }+ deriving Show+++-- | Statements that appear in the body of a loop.+data StmtBody+ -- | Evaluate a pure expression.+ = BodyStmt+ { -- | Bind for the result+ bodyResultBind :: Bind Name++ -- | Expression to evaluate+ , bodyExpression :: Exp () Name }+++ -- | Write to a vector.+ | BodyVecWrite+ { -- | Name of the vector.+ bodyVecName :: Name++ -- | Type of the element.+ , bodyVecWriteElemType :: Type Name++ -- | Expression for the index to write to.+ , bodyVecWriteIx :: Exp () Name++ -- | Expression for the value to write.+ , bodyVecWriteVal :: Exp () Name+ }+++ -- | Read from an accumulator.+ | BodyAccRead+ { -- | Name of the accumulator.+ bodyAccName :: Name++ -- | Type of the accumulator.+ , bodyAccType :: Type Name++ -- | Binder for the read value.+ , bodyAccNameBind :: Bind Name+ }+++ -- | Body of an accumulation operation.+ -- Writes to the accumulator.+ | BodyAccWrite+ { -- | Name of the accumulator.+ bodyAccName :: Name++ -- | Type of the accumulator.+ , bodyAccType :: Type Name++ -- | Expression to update the accumulator.+ , bodyAccExp :: Exp () Name }+ deriving Show+++-- | Statements that appear after a loop to cleanup.+data StmtEnd+ -- | Pure ending statements to produce the result of + -- the overall process.+ = EndStmt+ { endBind :: Bind Name+ , endExp :: Exp () Name }++ -- | Read the result of an accumulator.+ | EndAcc+ { endName :: Name+ , endType :: Type Name+ , endAccName :: Name }++ -- | Destructively slice down a vector to its final size.+ | EndVecSlice+ { endVecName :: Name+ , endVecType :: Type Name+ , endVecRate :: Type Name }+ deriving Show+
+ DDC/Core/Flow/Process.hs view
@@ -0,0 +1,8 @@++module DDC.Core.Flow.Process+ ( Process (..)+ , Operator (..))+where+import DDC.Core.Flow.Process.Process+import DDC.Core.Flow.Process.Operator+import DDC.Core.Flow.Process.Pretty ()
+ DDC/Core/Flow/Process/Operator.hs view
@@ -0,0 +1,123 @@++module DDC.Core.Flow.Process.Operator+ (Operator (..))+where+import DDC.Core.Flow.Exp+++-- | An abstract series operator.+--+-- Each of the constructors holds all the information we need to produce+-- code for that operator.+data Operator+ -----------------------------------------+ -- | Connect a series from one place to another.+ -- These don't come from the source program, but are useful for + -- during code generation.+ = OpId+ { -- Binder for result series.+ opResultSeries :: BindF++ -- Rate of the input series.+ , opInputRate :: TypeF++ -- Bound of the input series+ , opInputSeries :: BoundF++ -- Type of the elements.+ , opElemType :: TypeF+ }++ -----------------------------------------+ -- | Convert a series to a manifest vector.+ | OpCreate+ { -- | Binder for result vector+ opResultVector :: BindF++ -- | Rate of input series+ , opInputRate :: TypeF++ -- | Bound of input series.+ , opInputSeries :: BoundF++ -- | Rate that should be used when allocating the vector.+ -- This is filled in by `patchAllocRates`.+ , opAllocRate :: Maybe TypeF++ -- | Type of the 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.+ opArity :: Int++ -- | Binder for result series.+ , opResultSeries :: BindF++ -- | Rate of all input series.+ , opInputRate :: TypeF++ -- | Names for input series.+ , opInputSeriess :: [BoundF]++ -- | Worker input parameters+ , opWorkerParams :: [BindF]++ -- | Worker body+ , opWorkerBody :: ExpF+ }++ -----------------------------------------+ -- | Fold all the elements of a series.+ | OpFold+ { -- | Binder for result value.+ opResultValue :: BindF++ -- | Rate of input series.+ , opInputRate :: TypeF++ -- | 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++ -- | Worker body.+ , opWorkerBody :: ExpF }++ -----------------------------------------+ -- | Pack a series according to a selector.+ | OpPack+ { -- | Binder for result series.+ opResultSeries :: BindF++ -- | Rate of input series.+ , opInputRate :: TypeF++ -- | Bound of input series.+ , opInputSeries :: BoundF++ -- | Rate of output series.+ , opOutputRate :: TypeF++ -- | Type of a series element.+ , opElemType :: TypeF }+ deriving Show+
+ DDC/Core/Flow/Process/Pretty.hs view
@@ -0,0 +1,47 @@++module DDC.Core.Flow.Process.Pretty where+import DDC.Core.Flow.Process.Process+import DDC.Core.Flow.Process.Operator+import DDC.Base.Pretty+import DDC.Type.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)+++instance Pretty Operator where+ ppr op@OpId{}+ = vcat+ [ text "Id"+ , text " rate: " <> ppr (opInputRate op)+ , text " input: " <> ppr (opInputSeries op)+ , text " result: " <> ppr (opResultSeries op) ]++ ppr op@OpCreate{}+ = vcat+ [ text "Create"+ , text " rate: " <> ppr (opInputRate op)+ , text " input: " <> ppr (opInputSeries op) + , text " result: " <> ppr (opResultVector op) ]++ ppr op@OpMap{}+ = vcat+ [ text "Map"+ , text " rate: " <> ppr (opInputRate op) ]++ ppr op@OpFold{}+ = vcat+ [ text "Fold"+ , text " rate: " <> ppr (opInputRate op) ]++ ppr op@OpPack{}+ = vcat+ [ text "Pack"+ , text " input rate: " <> ppr (opInputRate op) + , text " output rate: " <> ppr (opOutputRate op) ]
+ DDC/Core/Flow/Process/Process.hs view
@@ -0,0 +1,55 @@++module DDC.Core.Flow.Process.Process+ (Process (..))+where+import DDC.Core.Flow.Process.Operator+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.+data Process+ = Process+ { -- | Name of whole process.+ -- This is taken from the function name in the original+ -- source code.+ processName :: Name++ -- | Type parameters to process.+ -- These are the type parameters of the original function.+ , processParamTypes :: [BindF]++ -- | Value parameters to process.+ -- These are the value parameters of the original function.+ , processParamValues :: [BindF]++ -- | Flow contexts in this process.+ -- This contains a ContextRate entry for all the Rate variables+ -- in the parameters, along with an entry for all the nested+ -- contexts introduced by the process itself.+ , processContexts :: [Context]++ -- | 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++ -- Final result of process.+ , processResult :: ExpF+ }+
+ DDC/Core/Flow/Profile.hs view
@@ -0,0 +1,100 @@++-- | Language profile for Disciple Core Flow.+module DDC.Core.Flow.Profile+ ( profile+ , lexModuleString+ , lexExpString+ , freshT+ , freshX)+where+import DDC.Core.Flow.Prim+import DDC.Core.Flow.Env+import DDC.Core.Fragment+import DDC.Core.Lexer+import DDC.Type.Exp+import DDC.Data.Token+import Control.Monad.State.Strict+import DDC.Type.Env (Env)+import qualified DDC.Type.Env as Env+++-- | Language profile for Disciple Core Flow.+profile :: Profile Name +profile+ = Profile+ { 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 }+++features :: Features+features + = Features+ { featuresTrackedEffects = False+ , featuresTrackedClosures = False+ , featuresFunctionalEffects = False+ , featuresFunctionalClosures = False+ , featuresPartialPrims = True+ , featuresPartialApplication = True+ , featuresGeneralApplication = True+ , featuresNestedFunctions = True+ , featuresDebruijnBinders = True+ , featuresUnboundLevel0Vars = False+ , featuresUnboxedInstantiation = True+ , featuresNameShadowing = True+ , featuresUnusedBindings = True+ , featuresUnusedMatches = True }+++-- | Lex a string to tokens, using primitive names.+--+-- The first argument gives the starting source line number.+lexModuleString :: String -> Int -> String -> [Token (Tok Name)]+lexModuleString sourceName lineStart str+ = map rn $ lexModuleWithOffside sourceName lineStart str+ where rn (Token strTok sp) + = case renameTok readName strTok of+ Just t' -> Token t' sp+ Nothing -> Token (KJunk "lexical error") sp+++-- | Lex a string to tokens, using primitive names.+--+-- The first argument gives the starting source line number.+lexExpString :: String -> Int -> String -> [Token (Tok Name)]+lexExpString sourceName lineStart str+ = map rn $ lexExp sourceName lineStart str+ where rn (Token strTok sp) + = case renameTok readName strTok of+ Just t' -> Token t' sp+ Nothing -> Token (KJunk "lexical error") sp+++-- | Create a new type variable name that is not in the given environment.+freshT :: Env Name -> Bind Name -> State Int Name+freshT env bb+ = do i <- get+ put (i + 1)+ let n = NameVar ("t" ++ show i)+ case Env.lookupName n env of+ Nothing -> return n+ _ -> freshT env bb+++-- | Create a new value variable name that is not in the given environment.+freshX :: Env Name -> Bind Name -> State Int Name+freshX env bb+ = do i <- get+ put (i + 1)+ let n = NameVar ("x" ++ show i)+ case Env.lookupName n env of+ Nothing -> return n+ _ -> freshX env bb+
+ DDC/Core/Flow/Transform/Concretize.hs view
@@ -0,0 +1,85 @@++module DDC.Core.Flow.Transform.Concretize+ (concretizeModule)+where+import DDC.Core.Module+import DDC.Core.Flow.Compounds+import DDC.Core.Flow.Prim+import DDC.Core.Flow.Exp+import DDC.Core.Transform.TransformUpX+import qualified DDC.Type.Env as Env+import qualified Data.Map as Map+++-- | Rewrite operators that use type level rates to ones that +-- use value level ones.+concretizeModule :: Module () Name -> Module () Name+concretizeModule mm+ = transformSimpleUpX concretizeX Env.empty Env.empty mm+++-- | Rewrite an expression to use concrete operators.+concretizeX + :: KindEnvF -> TypeEnvF+ -> ExpF -> Maybe ExpF++concretizeX _kenv tenv xx++ -- loop# -> loopn#+ | Just ( NameOpLoop OpLoopLoop+ , [XType tK, xF]) <- takeXPrimApps xx+ , Just (nS, _, tA) <- findSeriesWithRate tenv tK+ , xS <- XVar (UName nS)+ = Just + $ xLoopLoopN + tK -- type level rate+ (xRateOfSeries tK tA xS) -- + xF -- loop body++ -- newVectorR# -> newVectorN#+ | 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)+ + | otherwise+ = Nothing+++-- | Search the given environment for the name of a series with the+-- given rate parameter. We only look at named binders.+findSeriesWithRate + :: TypeEnvF -- ^ Type Environment.+ -> Type Name -- ^ Rate type.+ -> Maybe (Name, Type Name, Type Name)+ -- ^ Series name, rate type, element type.+findSeriesWithRate tenv tR+ = go (Map.toList (Env.envMap tenv))+ where + go [] = Nothing+ go ((n, tS) : moar)+ = case isSeriesTypeOfRate tR tS of+ Nothing -> go moar+ Just (_, tA) -> Just (n, tR, tA)+++-- | Given a rate type and a stream type, check whether the stream+-- is of the given rate. If it is then return the rate and element+-- types, otherwise `Nothing`.+isSeriesTypeOfRate + :: Type Name -> Type Name + -> Maybe (Type Name, Type Name)++isSeriesTypeOfRate tR tS+ | Just ( NameTyConFlow TyConFlowSeries+ , [tR', tA]) <- takePrimTyConApps tS+ , tR == tR'+ = Just (tR, tA)++ | otherwise+ = Nothing+
+ DDC/Core/Flow/Transform/Extract.hs view
@@ -0,0 +1,189 @@++module DDC.Core.Flow.Transform.Extract+ (extractModule)+where+import DDC.Core.Flow.Transform.Extract.Intersperse+import DDC.Core.Flow.Compounds+import DDC.Core.Flow.Procedure+import DDC.Core.Flow.Prim+import DDC.Core.Flow.Exp+import DDC.Core.Transform.Annotate+import DDC.Core.Module+++-- | Extract a core module from some stream procedures.+-- This produces vanilla core code again.+extractModule :: ModuleF -> [Procedure] -> ModuleF+extractModule orig procs+ = orig+ { moduleBody = annotate () $ extractTop procs }+++-- | Extract a top level binding from a procedure.+extractTop :: [Procedure] -> ExpF+extractTop procs+ = XLet (LRec (map extractProcedure procs)) xUnit+++-- | 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+ in ( BName n tQuant+ , xLAMs bsParam+ $ xLams xsParam+ $ extractNest nest stmts xResult )+++-------------------------------------------------------------------------------+-- | 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+++-------------------------------------------------------------------------------+-- | Extract code for a possibly nested loop.+extractLoop :: Nest -> [LetsF]++-- Code in a loop context.+extractLoop (NestLoop tRate starts bodys inner ends _result)+ = let + -- Starting statements.+ lsStart = concatMap extractStmtStart starts++ -- The loop itself.+ lLoop = LLet (BNone tUnit)+ (xApps (XVar (UPrim (NameOpLoop OpLoopLoop) + (typeOpLoop OpLoopLoop)))+ [ XType tRate -- loop rate+ , xBody ]) -- loop body++ -- The worker passed to the loop# combinator.+ xBody = XLam (BAnon tNat) -- loop counter.+ $ xLets (lsBody ++ lsInner)+ xUnit++ -- Process the elements.+ lsBody = concatMap extractStmtBody bodys++ -- Handle inner contexts.+ lsInner = extractLoop inner++ -- Ending statements + lsEnd = concatMap extractStmtEnd ends++ in lsStart ++ [lLoop] ++ lsEnd++-- Code in a select / if context.+extractLoop (NestIf _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.+ TVar (UName nK) = tRateInner+ uCounter = UName (NameVarMod nK "count")++ xGuard = xLoopGuard xFlag (XVar uCounter)+ ( XLam (BAnon tNat)+ $ xLets (lsBody ++ lsNested) xUnit)++ -- Selector context.+ lsBody = concatMap extractStmtBody stmtsBody++ -- Nested contexts.+ lsNested = extractLoop nested++ in [LLet (BNone tUnit) xGuard]+++extractLoop NestEmpty+ = []++extractLoop (NestList nests)+ = concatMap extractLoop nests+++-------------------------------------------------------------------------------+-- | Extract loop starting code.+-- This comes before the main loop.+extractStmtStart :: StmtStart -> [LetsF]+extractStmtStart ss+ = case ss of+ -- Allocate a new vector+ StartVecNew nVec tElem tRate'+ -> [LLet (BName nVec (tVector tElem))+ (xNewVectorR tElem tRate') ]+++ -- Initialise the accumulator for a reduction operation.+ StartAcc n t x + -> [LLet (BName n (tRef t)) + (xNew t x)] +++-------------------------------------------------------------------------------+-- | Extract loop body code.+extractStmtBody :: StmtBody -> [LetsF]+extractStmtBody sb+ = case sb of+ BodyStmt b x+ -> [ LLet b x ]++ -- Write to a vector.+ BodyVecWrite nVec tElem xIx xVal+ -> [ LLet (BNone tUnit)+ (xWriteVector tElem (XVar (UName nVec)) xIx xVal)]++ -- Read from an accumulator.+ BodyAccRead n t bVar+ -> [ LLet bVar+ (xRead t (XVar (UName n))) ]++ -- Accumulate an element from a stream.+ BodyAccWrite nAcc tElem xWorker + -> [ LLet (BNone tUnit)+ (xWrite tElem (XVar (UName nAcc)) xWorker)]+++-------------------------------------------------------------------------------+-- | Extract loop ending code.+-- This comes after the main loop.+extractStmtEnd :: StmtEnd -> [LetsF]+extractStmtEnd se+ = case se of+ EndStmt b x+ -> [LLet b x]++ -- Read the accumulator of a reduction operation.+ EndAcc n t nAcc + -> [LLet (BName n t) + (xRead t (XVar (UName nAcc))) ]++ -- Slice.+ EndVecSlice nVec tElem tRate + -> let + -- Get the name of the counter.+ TVar (UName nK) = tRate+ uCounter = UName (NameVarMod nK "count")+ xCounter = xRead tInt (XVar uCounter)+ xVec = XVar (UName nVec)++ -- Read the counter in a let since it will need to be threaded+ in [ LLet (BAnon tInt)+ xCounter++ , LLet (BName nVec (tVector tElem)) + (xSliceVector tElem (XVar (UIx 0)) xVec) ]+
+ DDC/Core/Flow/Transform/Extract/Intersperse.hs view
@@ -0,0 +1,53 @@++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/Prep.hs view
@@ -0,0 +1,169 @@++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/Schedule.hs view
@@ -0,0 +1,252 @@++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)++ | otherwise+ = error $ renderIndent + $ vcat [ text "ddc-core-flow.scheduleOperator"+ , indent 4 $ text "Can't schedule operator."+ , indent 4 $ ppr op ]++
+ DDC/Core/Flow/Transform/Schedule/Nest.hs view
@@ -0,0 +1,177 @@++module DDC.Core.Flow.Transform.Schedule.Nest+ ( insertContext+ , insertStarts+ , insertBody+ , insertEnds)+where+import DDC.Core.Flow.Procedure+import DDC.Core.Flow.Compounds+import DDC.Core.Flow.Prim+import DDC.Core.Flow.Exp+import Data.Monoid+++-------------------------------------------------------------------------------+-- | 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++-- Loop context at top level.+insertContext NestEmpty context@ContextRate{}+ = Just $ nestOfContext context++-- Selector context inside loop context.+insertContext nest@NestLoop{} context@ContextSelect{}+ | nestRate nest == contextOuterRate context+ = Just $ nest + { nestInner = nestInner nest <> nestOfContext context + , nestStart = nestStart nest ++ startsForSelect context }++-- Selector context needs to be inserted deeper in this nest.+insertContext nest@NestLoop{} context@ContextSelect{}+ | nestContainsRate nest (contextOuterRate context)+ , Just inner' <- insertContext (nestInner nest) context+ = Just $ nest + { nestInner = inner' + , nestStart = nestStart nest ++ startsForSelect context }++-- Nested selector context inside selector context.+insertContext nest@NestIf{} context@ContextSelect{}+ | nestInnerRate nest == contextOuterRate context+ = Just $ nest { nestInner = nestInner nest <> nestOfContext context }+++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 }++ ContextSelect{}+ -> NestIf+ { nestOuterRate = contextOuterRate context+ , nestInnerRate = contextInnerRate context+ , nestFlags = contextFlags context+ , nestBody = [] + , nestInner = NestEmpty }+++-- | Check whether the top-level of this nest contains the given rate.+-- It might be in a nested context.+nestContainsRate :: Nest -> TypeF -> Bool+nestContainsRate nest tRate+ = case nest of+ NestEmpty + -> False++ NestList ns + -> any (flip nestContainsRate tRate) ns++ NestLoop{}+ -> nestRate nest == tRate+ || nestContainsRate (nestInner nest) tRate++ NestIf{}+ -> 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 }]+++-------------------------------------------------------------------------------+-- | Insert starting statements in the given context.+insertStarts :: Nest -> Context -> [StmtStart] -> Maybe Nest++-- The starts are for this loop.+insertStarts nest@NestLoop{} (ContextRate tRate) starts'+ | tRate == nestRate nest+ = Just $ nest { nestStart = nestStart nest ++ starts' }++-- 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' }++insertStarts _ _ _+ = Nothing+++-------------------------------------------------------------------------------+-- | 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)++insertBody (NestList (n:ns)) context body'+ | Just (NestList ns') <- insertBody (NestList ns) context body'+ = Just $ NestList (n:ns')++insertBody (NestList []) _ _+ = Nothing+ +insertBody _ _ _+ = Nothing+++-------------------------------------------------------------------------------+-- | Insert ending statements in the given context.+insertEnds :: Nest -> Context -> [StmtEnd] -> Maybe Nest++-- The ends are for this loop.+insertEnds nest@NestLoop{} (ContextRate tRate) ends'+ | tRate == nestRate nest+ = Just $ nest { nestEnd = nestEnd nest ++ ends' }++-- 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+
+ DDC/Core/Flow/Transform/Schedule/SeriesEnv.hs view
@@ -0,0 +1,157 @@++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
@@ -0,0 +1,199 @@+module DDC.Core.Flow.Transform.Slurp+ (slurpProcesses)+where+import DDC.Core.Flow.Transform.Slurp.Alloc+import DDC.Core.Flow.Transform.Slurp.Operator+import DDC.Core.Flow.Prim+import DDC.Core.Flow.Context+import DDC.Core.Flow.Process+import DDC.Core.Flow.Compounds+import DDC.Core.Flow.Exp+import DDC.Core.Transform.Deannotate+import DDC.Core.Module+import Data.Maybe+import Data.List+++-- | Slurp stream processes from the top level of a module.+slurpProcesses :: Module () Name -> [Process]+slurpProcesses mm+ = slurpProcessesX (deannotate (const Nothing) $ moduleBody mm)+++-- | Slurp stream processes from a module body.+slurpProcessesX :: Exp () Name -> [Process]+slurpProcessesX xx+ = case xx of+ XLet lts x'+ -> slurpProcessesLts lts ++ slurpProcessesX x'++ _ -> []+++-- | Slurp stream processes from the top-level let expressions.+slurpProcessesLts :: Lets () Name -> [Process]+slurpProcessesLts (LRec binds)+ = catMaybes [slurpProcessLet b x | (b, x) <- binds]++slurpProcessesLts (LLet b x)+ = catMaybes [slurpProcessLet b x]++slurpProcessesLts _+ = []+++-------------------------------------------------------------------------------+-- | Slurp stream operators from a top-level binding.+slurpProcessLet :: Bind Name -> Exp () Name -> Maybe Process+slurpProcessLet (BName n tProcess) xx++ -- We assume that all type params come before the value params.+ | Just (fbs, xBody) <- takeXLamFlags xx+ = let + -- Split binders into type and value binders.+ (fbts, fbvs) = partition fst fbs++ -- Type binders.+ bts = map snd fbts+ tsRate = filter (\b -> typeOfBind b == kRate) bts++ -- Create contexts for all the parameter rate variables.+ ctxParam = map (ContextRate . TVar . UName)+ $ map (\(BName nRate _) -> nRate)+ $ tsRate++ -- Value binders.+ 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 Just $ Process+ { processName = n+ , processParamTypes = bts+ , processParamValues = bvs++ -- Note that the parameter contexts needs to come first+ -- so they are scheduled before the local contexts, which+ -- are inside + , processContexts = ctxParam ++ ctxLocal++ , processOperators = ops_alloc+ , processStmts = ltss+ , processResultType = tResult+ , processResult = xResult }++slurpProcessLet _ _+ = Nothing+++-------------------------------------------------------------------------------+-- | Slurp stream operators from the body of a function and add them to +-- the provided loop nest.+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.++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)++ -- 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)++ | otherwise+ = ([], [], [], 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.++-- Decend into more let bindings.+-- We get these when entering into a nested context.+slurpBindingX 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)++-- Slurp a mkSel1#+-- This creates a nested selector context.+slurpBindingX b + ( takeXPrimApps + -> Just ( NameOpFlow (OpFlowMkSel 1)+ , [ XType tK1, XType _tA+ , XVar uFlags+ , XLAM (BName nR kR) (XLam bSel xBody)]))+ | kR == kRate+ = let + (ctxInner, osInner, ltsInner)+ = slurpBindingX 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)++ opId = OpId+ { opResultSeries = bFlagsUse+ , opInputRate = tK1+ , opInputSeries = uFlags + , opElemType = tBool }++ context = ContextSelect+ { contextOuterRate = tK1+ , contextInnerRate = TVar (UName nR)+ , contextFlags = uFlagsUse+ , contextSelector = bSel }++ in (context : ctxInner, opId : osInner, ltsInner)++-- | 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], [])++ -- This is some base-band statement that doesn't + -- work on a flow operator.+ _ -> ([], [], [LLet b x])+
+ DDC/Core/Flow/Transform/Slurp/Alloc.hs view
@@ -0,0 +1,41 @@++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/Operator.hs view
@@ -0,0 +1,102 @@++module DDC.Core.Flow.Transform.Slurp.Operator+ (slurpOperator)+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 ()+++-- | Slurp a stream operator from a let-binding binding.+-- We use this when recovering operators from the source program.+slurpOperator + :: Bind Name + -> Exp () Name + -> Maybe Operator++slurpOperator bResult xx++ -- Create --------------------------------------+ | Just ( NameOpFlow OpFlowVectorOfSeries+ , [ XType tRate, XType tA, (XVar uSeries) ])+ <- takeXPrimApps xx+ = Just $ OpCreate+ { opResultVector = bResult+ , opInputRate = tRate+ , opInputSeries = uSeries + , opAllocRate = Nothing+ , opElemType = tA }++ -- Map -----------------------------------------+ | Just (NameOpFlow (OpFlowMap n), xs) + <- takeXPrimApps xx+ , n >= 1+ , XType tR : xsArgs2 <- xs+ , (xsA, xsArgs3) <- splitAt (n + 1) xsArgs2+ , tsA <- [ t | XType t <- xsA ]+ , length tsA == n + 1+ , xWorker : xsSeries <- xsArgs3+ , usSeries <- [ u | XVar u <- xsSeries ]+ , length usSeries == n+ , Just (psIn, xBody) <- takeXLams xWorker+ , length psIn == n+ = Just $ OpMap+ { opArity = n+ , opResultSeries = bResult+ , opInputRate = tR+ , opInputSeriess = usSeries+ , opWorkerParams = psIn+ , 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+ , [ XType tRateInput, XType tRateOutput, XType tElem+ , _xSel, (XVar uSeries) ]) <- takeXPrimApps xx+ = Just $ OpPack+ { opResultSeries = bResult+ , opInputRate = tRateInput+ , opInputSeries = uSeries+ , opOutputRate = tRateOutput + , opElemType = tElem }++ | otherwise+ = Nothing+
+ DDC/Core/Flow/Transform/Thread.hs view
@@ -0,0 +1,203 @@++-- | Definition for the thread transform.+module DDC.Core.Flow.Transform.Thread+ ( threadConfig+ , wrapResultType+ , wrapResultExp+ , unwrapResult+ , threadType)+where+import DDC.Core.Flow.Compounds+import DDC.Core.Flow.Profile+import DDC.Core.Flow.Prim+import DDC.Core.Compounds as C+import DDC.Core.Exp+import DDC.Core.Transform.Thread+import DDC.Core.Transform.Reannotate+import DDC.Core.Check (AnTEC (..))+import qualified DDC.Core.Check as Check+++-- | Thread config defines what state token to use,+-- and what functions need to have it threaded though them.+threadConfig :: Config () Name+threadConfig+ = Config+ { configCheckConfig = Check.configOfProfile profile+ , configTokenType = tWorld+ , configVoidType = tUnit+ , configWrapResultType = wrapResultType+ , configWrapResultExp = wrapResultExp+ , configThreadMe = threadType + , configThreadPat = unwrapResult }+++-- | Wrap the result type of a stateful computation with the state type.+wrapResultType :: Type Name -> Type Name+wrapResultType tt+ | Just (TyConBound u _, tsArgs) <- takeTyConApps tt+ , UPrim n _ <- u+ , NameTyConFlow (TyConFlowTuple _) <- n+ = tTupleN (tWorld : tsArgs)++ | otherwise+ = tTuple2 tWorld tt+++-- | Wrap the result of a stateful computation with the state token.+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 + = reannotate annotTail xWorld++ -- Rewrite (TupleN a1 a2 .. x1 x2 ..) + -- => (TupleN World# a1 a2 .. world x1 x2 ..)+ | Just aWorld <- takeAnnotOfExp xWorld+ , Just aResult <- takeAnnotOfExp 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]+++ _ -> C.xApps () (XCon () (dcTupleN 2))+ [ XType tWorld'+ , XType tResult+ , xWorld'+ , xResult' ]++ | otherwise+ = error "ddc-core-flow: wrapResultExp can't get type annotations"+++-- | Make a pattern to unwrap the result of a stateful computation.+unwrapResult :: Name -> Maybe (Bind Name -> [Bind Name] -> Pat Name)+unwrapResult _+ = Just unwrap++ where unwrap bWorld bsResult + | [bResult] <- bsResult+ , typeOfBind bResult == tUnit+ = PData dcTuple1 [bWorld] ++ | otherwise+ = PData (dcTupleN (length (bWorld : bsResult)))+ (bWorld : bsResult)+++-- | Get the new type for a stateful primop.+-- The new types have a World# token threaded though them, which make them+-- suitable for applying the Thread transform when converting a Core Flow+-- program to a language that needs such state threading (like GHC Core).+threadType :: Name -> Type Name -> Maybe (Type Name)+threadType n _+ = case n of+ -- Assignables --------------------------+ -- new# :: [a : Data]. a -> World# -> T2# (World#, Ref# a)+ NameOpStore OpStoreNew+ -> 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 + `tFun` tWorld `tFun` (tTuple2 tWorld (tRef tA))++ -- write# :: [a : Data]. Ref# -> a -> World# -> World#+ NameOpStore OpStoreWrite + -> Just $ tForall kData+ $ \tA -> tRef tA `tFun` tA + `tFun` tWorld `tFun` tWorld++ -- Vectors -------------------------------+ -- newVector# :: [a : Data]. Nat# -> World# -> T2# World# (Vector# a)+ NameOpStore OpStoreNewVector+ -> Just $ tForall kData+ $ \tA -> tNat + `tFun` tWorld `tFun` (tTuple2 tWorld (tVector tA))++ -- newVectorN# :: [a : Data]. [k : Rate]. RateNat# k + -- -> World# -> T2# (World#, Vector# a)+ NameOpStore OpStoreNewVectorN+ -> Just $ tForalls [kData, kRate]+ $ \[tA, tK] + -> tRateNat tK + `tFun` tWorld `tFun` (tTuple2 tWorld (tVector tA))++ -- readVector# :: [a : Data]. Vector# a -> Nat# -> World# -> T2# World# a+ NameOpStore OpStoreReadVector+ -> Just $ tForall kData+ $ \tA -> tA `tFun` tVector tA `tFun` tNat + `tFun` tWorld `tFun` (tTuple2 tWorld tA)++ -- writeVector# :: [a : Data]. Vector# a -> Nat# -> a -> World# -> World#+ NameOpStore OpStoreWriteVector+ -> Just $ tForall kData+ $ \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+ -> Just $ tForall kData+ $ \tA -> tNat `tFun` tVector tA + `tFun` tWorld `tFun` (tTuple2 tWorld (tVector tA))+++ -- Streams ------------------------------+ -- next# :: [k : Rate]. [a : Data]+ -- . Series# k a -> Int# -> World# -> (World#, a)+ NameOpStore OpStoreNext+ -> Just $ tForalls [kRate, kData]+ $ \[tK, tA] -> tSeries tK tA `tFun` tInt + `tFun` tWorld `tFun` (tTuple2 tWorld tA)++ -- Contexts -----------------------------+ -- loopn# :: [k : Rate]. RateNat# k + -- -> (Nat# -> World# -> World#) + -- -> World# -> World#+ NameOpLoop OpLoopLoopN+ -> Just $ tForalls [kRate]+ $ \[tK] -> tRateNat tK+ `tFun` (tNat `tFun` tWorld `tFun` tWorld)+ `tFun` tWorld `tFun` tWorld+ + -- guard#+ NameOpLoop OpLoopGuard+ -> Just $ tRef tNat+ `tFun` tBool+ `tFun` (tNat `tFun` tWorld `tFun` tWorld)+ `tFun` tWorld `tFun` tWorld++ _ -> Nothing+
+ DDC/Core/Flow/Transform/Wind.hs view
@@ -0,0 +1,510 @@++-- | Convert a loop expressed with the loopn# and guard# combinators into+-- a tail recursive loop with accumulators.+--+-- ASUMPTIONS:+--+-- * No nested loops.+-- We could support these, but we don't yet.+-- +-- * Outer control flow is only defined via the loopn# and guard# +-- combinators.+--+-- * References don't escape, +-- so they're not stored in data structures or captured in closures.+--+-- * No aliasing of references, +-- so updating ref with a particular name does not affect any other ref.+-- +-- * Refs holding loop counters for loopn# and entry counters for guard# +-- are not written to by any other statements.+-- +-- The above assumptions are true for code generated with the lowering+-- transform, but won't be true for general code, and we don't check for+-- violiations of these assumptions.+--+module DDC.Core.Flow.Transform.Wind+ ( RefInfo(..)+ , windModule)+where+import DDC.Core.Module+import DDC.Core.Exp+import DDC.Core.Flow+import DDC.Core.Flow.Prim+import DDC.Core.Compounds+import DDC.Core.Flow.Compounds (tNat, dcNat, dcTupleN, dcBool, tTupleN)+import qualified Data.Map as Map+import Data.Map (Map)+++-------------------------------------------------------------------------------+-- | Current information for a reference.+data RefInfo+ = RefInfo+ { refInfoName :: Name+ , refInfoType :: Type Name+ , refInfoCurrent :: Name + , refInfoVersionNumber :: Int }++data RefMap+ = RefMap (Map Name RefInfo)++refMapZero :: RefMap+refMapZero = RefMap Map.empty++refMapElems :: RefMap -> [RefInfo]+refMapElems (RefMap mm)+ = Map.elems mm+++-- | Insert a new `RefInfo` record into the map.+insertRefInfo :: RefInfo -> RefMap -> RefMap+insertRefInfo info (RefMap mm)+ = RefMap (Map.insert (refInfoName info) info mm)+++-- | Lookup a `RefInfo` record from the map.+lookupRefInfo :: RefMap -> Name -> Maybe RefInfo+lookupRefInfo (RefMap mm) n+ = Map.lookup n mm+++-- | Get the name of the current version of a value from a `RefInfo`.+nameOfRefInfo :: RefInfo -> Maybe Name+nameOfRefInfo info+ = Just $ NameVarMod (refInfoName info) (show $ refInfoVersionNumber info)+++-- | Bump the version number of a `RefInfo`+bumpVersionOfRefInfo :: RefInfo -> RefInfo+bumpVersionOfRefInfo info+ = info { refInfoVersionNumber = refInfoVersionNumber info + 1 }+++-- | Bump the version number of one element of a `RefMap`.+bumpVersionInRefMap :: Name -> RefMap -> RefMap+bumpVersionInRefMap n (RefMap mm)+ = RefMap $ Map.update (Just . bumpVersionOfRefInfo) n mm+++-- | Bump the version numbers of all elements of a `RefMap`.+bumpAllVersionsInRefMap :: RefMap -> RefMap+bumpAllVersionsInRefMap mm+ = foldr bumpVersionInRefMap mm $ map refInfoName $ refMapElems mm+++-------------------------------------------------------------------------------+data Context+ -- | We're currently in the body of a loop.+ = ContextLoop + { contextLoopName :: Name+ , contextLoopCounter :: Name+ , contextLoopAccs :: [Name] }++ -- | We're currently in the body of a guard.+ | ContextGuard+ { -- | Name of the entry counter,+ -- the number of times this guard has matched.+ contextGuardCounter :: Name++ -- | Whether we're in the matching or non-matching branch.+ , contextGuardFlag :: Bool }+ deriving Show+++-- | 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+makeTailCallFromContexts a refMap context@(ContextLoop nLoop _ _ : _)+ = let + xLoop = XVar a (UName nLoop)+ xArgs = slurpArgUpdates a refMap [] context++ in xApps a xLoop xArgs+ +makeTailCallFromContexts _ _ _+ = error $ unlines+ [ "ddc-core-flow.makeTailCallFromContexts" + , " Can't make a tailcall for this context." ]+++-- | 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.+slurpArgUpdates + :: a+ -> RefMap+ -> [(Name, Exp a Name)] + -> [Context] + -> [Exp a Name]++slurpArgUpdates a refMap [] (ContextLoop _ nCounter nAccs : more)+ = let+ -- Expression to update loop counter.+ nxCounter' + = ( nCounter+ , xIncrement a (XVar a (UName nCounter)) )++ -- Updated accumulators.+ nxAccs' + = [ (nAcc, XVar a (UName nAcc'))+ | nAcc <- nAccs+ , let Just info = lookupRefInfo refMap nAcc+ , let Just nAcc' = nameOfRefInfo info ]++ in slurpArgUpdates a refMap (nxCounter' : nxAccs') more++-- If we're inside the true branch of a guard then update+-- the associated entry counter for the guard.+slurpArgUpdates a refMap args (ContextGuard nCounter flag : more)+ | flag == True+ = let + update [] = []+ update ((n, x) : args')+ | n == nCounter = (n, xIncrement a x) : update args'+ | otherwise = (n, x) : update args'++ in slurpArgUpdates a refMap (update args) more++ | otherwise+ = slurpArgUpdates a refMap args more++slurpArgUpdates _ _ _ (ContextLoop{} : _)+ = error $ unlines+ [ "ddc-core-flow.slurpArgUpdates"+ , " Nested loops are not supported." ]++slurpArgUpdates _ _ args []+ = map snd args+++-- | Build an expression that increments a natural.+xIncrement :: a -> Exp a Name -> Exp a Name+xIncrement a xx+ = xApps a (XVar a (UPrim (NamePrimArith PrimArithAdd) + (typePrimArith PrimArithAdd)))+ [ XType 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]+++-------------------------------------------------------------------------------+windModule :: Module () Name -> Module () Name+windModule m+ = let body' = windModuleBodyX (moduleBody m)+ in m { moduleBody = body' }+++-- | Do winding in the body of a module.+windModuleBodyX :: Exp () Name -> Exp () Name+windModuleBodyX xx+ = case xx of+ XLet a (LLet b x1) x2+ -> let x1' = windBodyX refMapZero [] x1+ x2' = windModuleBodyX x2+ in XLet a (LLet b x1') x2'++ XLet a (LRec bxs) x2+ -> let bxs' = [(b, windBodyX refMapZero [] x) | (b, x) <- bxs]+ x2' = windModuleBodyX x2+ in XLet a (LRec bxs') x2'++ XLet a lts x2+ -> let x2' = windModuleBodyX x2+ in XLet a lts x2'++ _ -> xx+++-------------------------------------------------------------------------------+-- | Do winding in the body of a function.+windBodyX + :: RefMap -- ^ Info about how references are being rewritten.+ -> [Context] -- ^ What loops and guards we're currently inside.+ -> Exp () Name -- ^ Rewrite this expression.+ -> Exp () Name++windBodyX refMap context xx+ = let down = windBodyX refMap context+ in case xx of++ -----------------------------------------+ -- Detect ref allocation,+ -- to bind the initial value to a new variable.+ --+ -- ref : Ref# type = new# [type] val+ -- => ref__0 : type = val+ --+ XLet a (LLet (BName nRef _) x) x2+ | Just ( NameOpStore OpStoreNew+ , [XType tElem, xVal] ) <- takeXPrimApps x+ -> let + -- Add the new ref record to the map.+ info = RefInfo + { refInfoName = nRef+ , refInfoType = tElem+ , refInfoCurrent = nInit + , refInfoVersionNumber = 0 }++ -- Rewrite the statement that creates a new ref to one+ -- that just binds the initial value.+ Just nInit = nameOfRefInfo info+ refMap' = insertRefInfo info refMap++ in XLet a (LLet (BName nInit tElem) xVal)+ (windBodyX refMap' context x2)+++ -----------------------------------------+ -- Detect ref read,+ -- and rewrite to use the current version of the variable.+ -- val : type = read# [type] ref+ -- => val : type = ref_N+ --+ XLet a (LLet bResult x) x2+ | Just ( NameOpStore OpStoreRead+ , [XType _tElem, XVar _ (UName nRef)] ) + <- takeXPrimApps x+ , Just info <- lookupRefInfo refMap nRef+ , Just nVal <- nameOfRefInfo info+ -> XLet a (LLet bResult (XVar a (UName nVal)))+ (windBodyX refMap context x2)+++ -----------------------------------------+ -- Detect ref write,+ -- to just bind the new value.+ XLet a (LLet (BNone _) x) x2+ | Just ( NameOpStore OpStoreWrite + , [XType _tElem, XVar _ (UName nRef), xVal])+ <- takeXPrimApps x+ , refMap' <- bumpVersionInRefMap nRef refMap+ , Just info <- lookupRefInfo refMap' nRef+ , Just nVal <- nameOfRefInfo info+ , tVal <- refInfoType info+ -> XLet a (LLet (BName nVal tVal) xVal)+ (windBodyX refMap' context x2)+++ -----------------------------------------+ -- Detect loop combinator.+ XLet a (LLet (BNone _) x) x2+ | Just ( NameOpLoop OpLoopLoopN+ , [ 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"+ bLoop = BName nLoop tLoop+ uLoop = UName nLoop++ nLength = NameVarMod nK "length"+ bLength = BName nLength tNat+ uLength = UName nLength++ -- RefMap for before the loop, in the body, and after the loop.+ refMap_init = refMap+ refMap_body = bumpAllVersionsInRefMap refMap+ refMap_final = bumpAllVersionsInRefMap refMap_body++ -- Get binds and bounds for accumluators,+ -- to use in the body of the loop.+ bsAccs = [ BName nVar (refInfoType info)+ | info <- refMapElems refMap_body+ , let Just nVar = nameOfRefInfo info ]++ usAccs = takeSubstBoundsOfBinds bsAccs+ tsAccs = map typeOfBind bsAccs+++ -- The loop function itself will return us a tuple+ -- containing the final value of all the accumulators.+ tIndex = typeOfBind bIx+ tResult = loopResultT tsAccs++ -- Type of the loop function.+ tLoop = foldr tFun tResult (tIndex : tsAccs)+++ -- Decend into loop body,+ -- and remember that we're doing the rewrite inside a loop context.+ context' = context+ ++ [ ContextLoop + { contextLoopName = nLoop+ , contextLoopCounter = nIx+ , contextLoopAccs = map refInfoName + $ refMapElems refMap_body } ]++ xBody' = windBodyX refMap_body context' xBody+++ -- Create the loop driver.+ -- This is the code that tests for the end-of-loop condition.+ xDriver = xLams a (bIx : bsAccs) + $ XCase a (xSubInt a (XVar a uLength) (XVar a (UName nIx)))+ [ AAlt (PData (dcNat 0) []) xResult+ , AAlt PDefault xBody' ]++ xResult = loopResultX a + tsAccs+ [XVar a u | u <- usAccs]++ -- Initial values of index and accumulators.+ xsInit = XCon a (dcNat 0)+ : [ XVar a (UName nVar)+ | info <- refMapElems refMap_init+ , let Just nVar = nameOfRefInfo info ]+++ -- Decend into loop postlude.+ bsFinal = [ BName nVar (refInfoType info)+ | info <- refMapElems refMap_final+ , let Just nVar = nameOfRefInfo info ]++ x2' = windBodyX refMap_final context x2+++ in XLet a (LLet bLength (xNatOfRateNat tK xLength))+ $ XLet a (LRec [(bLoop, xDriver)]) + $ runUnpackLoop + a + tsAccs -- Types of accumulators.+ (xApps a (XVar a uLoop) xsInit) -- Expression to invoke loop+ bsFinal -- Binders for final accumulators+ x2' -- Continuation expression+++ -----------------------------------------+ -- Detect guard combinator.+ XLet a (LLet (BNone _) x) x2+ | Just ( NameOpLoop OpLoopGuard+ , [ XVar _ (UName nCountRef)+ , xFlag+ , XLam _ bCount xBody ]) <- takeXPrimApps x+ -> let + Just infoCount = lookupRefInfo refMap nCountRef++ Just nCount = nameOfRefInfo infoCount++ context' = context+ ++ [ ContextGuard+ { contextGuardCounter = nCountRef+ , contextGuardFlag = True } ]++ xBody' = XLet a (LLet bCount (XVar a (UName nCount)))+ $ windBodyX refMap context' xBody++ in XCase a xFlag + [ AAlt (PData (dcBool True) []) xBody'+ , AAlt PDefault (down x2) ]+++ -----------------------------------------+ -- 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.+ XCon a dc+ | dc == dcUnit+ -> makeTailCallFromContexts a refMap context+++ -- Boilerplate --------------------------+ XVar{} -> xx+ XCon{} -> xx+ XLAM a b x -> XLAM a b (down x)+ XLam a b x -> XLam a b (down x)++ XApp{} -> xx++ -- Decend into nest let binding.+ -- We need to drop the contexts because we never do a tail-call+ -- from a nested binding.+ XLet a (LLet b x) x2+ -> XLet a (LLet b (windBodyX refMap [] x)) + (down x2)++ XLet a (LRec bxs) x2+ -> XLet a (LRec [(b, windBodyX refMap [] x) | (b, x) <- bxs])+ (down x2)++ XLet a lts x2+ -> XLet a lts (down x2)++ XCase{}+ -> error $ unlines+ [ "ddc-core-flow.windBodyX"+ , " case-expressions not supported yet" ]++ XCast a c x+ -> let x' = windBodyX refMap context x+ in XCast a c x'++ XType{} -> xx+ XWitness{} -> xx+++xNatOfRateNat :: Type Name -> Exp () Name -> Exp () Name+xNatOfRateNat tK xR+ = xApps () + (xVarOpFlow OpFlowNatOfRateNat)+ [XType tK, xR]++xVarOpFlow :: OpFlow -> Exp () Name+xVarOpFlow op+ = XVar () (UPrim (NameOpFlow op) (typeOpFlow op))+++-------------------------------------------------------------------------------+-- | Make the type of a loop result, +-- given the types of the accumulators for that loop. +--+-- If we have no accumulators, return Unit.+-- If we have just one, return that value.+-- If more, then package them into a tuple.+--+loopResultT :: [Type Name] -> Type Name+loopResultT tsAccs+ = case tsAccs of+ [] -> tUnit+ [tAcc] -> tAcc+ _ -> tTupleN tsAccs+++-- | Make a loop result,+-- given the expressions for the accumulators.+loopResultX :: a -> [Type Name] -> [Exp a Name] -> Exp a Name+loopResultX a tsAccs xsAccs+ = case xsAccs of+ [] -> xUnit a+ [x] -> x+ _ -> xApps a (XCon a (dcTupleN $ length tsAccs)) + ([XType t | t <- tsAccs] ++ xsAccs)+++-- | Call a loop, and unpack its result.+runUnpackLoop + :: a + -> [Type Name] -- ^ Types of accumulators.+ -> Exp a Name -- ^ Expression to invoke the loop.+ -> [Bind Name] -- ^ Binders for the accumulated values.+ -> Exp a Name -- ^ Continuation expression.+ -> Exp a Name++runUnpackLoop a tsAccs xRunLoop bsAcc xCont+ | [] <- tsAccs+ = XLet a (LLet (BNone tUnit) xRunLoop) xCont++ | [_t] <- tsAccs+ , [b] <- bsAcc+ = XLet a (LLet b xRunLoop) xCont++ | otherwise+ = XCase a xRunLoop+ [ AAlt (PData (dcTupleN $ length tsAccs) bsAcc) xCont ]+
+ LICENSE view
@@ -0,0 +1,30 @@+--------------------------------------------------------------------------------+The Disciplined Disciple Compiler License (MIT style)++Copyrite (K) 2007-2013 The Disciplined Disciple Compiler Strike Force+All rights reversed.++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++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+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ddc-core-flow.cabal view
@@ -0,0 +1,105 @@+Name: ddc-core-flow+Version: 0.3.2.1+License: MIT+License-file: LICENSE+Author: The Disciplined Disciple Compiler Strike Force+Maintainer: Ben Lippmeier <benl@ouroborus.net>+Build-Type: Simple+Cabal-Version: >=1.6+Stability: experimental+Category: Compilers/Interpreters+Homepage: http://disciple.ouroborus.net+Synopsis: Disciplined Disciple Compiler data flow compiler.+Description: + Disciple Core Flow is a Domain Specific Language (DSL) for writing first+ order data flow programs.+ + This package provides the language definition as a fragment of Disciple+ Core. It also provides an implementation of the lowering transform which+ converts data flow programs into imperative nested loop code.++ The @repa-plugin@ package provides a GHC plugin that transforms GHC core+ programs gained from vanilla Haskell sources. Use this package if you+ just want to write and run real programs.++ Alternatively, Disciple Core Flow programs can be transformed directly+ via the @ddc@ or @ddci-core@ command line interfaces, but DDC itself+ doesn't provide full compilation to machine code. Use GHC and the + @repa-plugin@ for that.+ ++Library+ Build-Depends: + base == 4.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.*++ 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.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++ Other-modules:+ 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.OpPrim++ DDC.Core.Flow.Transform.Slurp.Operator+ DDC.Core.Flow.Transform.Slurp.Alloc++ DDC.Core.Flow.Transform.Schedule.SeriesEnv+ DDC.Core.Flow.Transform.Schedule.Nest++ DDC.Core.Flow.Transform.Extract.Intersperse+++ GHC-options:+ -fno-warn-orphans+ -fno-warn-missing-signatures+ -fno-warn-unused-do-bind++ Extensions:+ KindSignatures+ NoMonomorphismRestriction+ ScopedTypeVariables+ StandaloneDeriving+ PatternGuards+ ParallelListComp+ DeriveDataTypeable+ ViewPatterns+