diff --git a/DDC/Core/Flow.hs b/DDC/Core/Flow.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow.hs @@ -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 diff --git a/DDC/Core/Flow/Compounds.hs b/DDC/Core/Flow/Compounds.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Compounds.hs @@ -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 diff --git a/DDC/Core/Flow/Context.hs b/DDC/Core/Flow/Context.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Context.hs @@ -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) + diff --git a/DDC/Core/Flow/Env.hs b/DDC/Core/Flow/Env.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Env.hs @@ -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 + diff --git a/DDC/Core/Flow/Exp.hs b/DDC/Core/Flow/Exp.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Exp.hs @@ -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 diff --git a/DDC/Core/Flow/Prim.hs b/DDC/Core/Flow/Prim.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Prim.hs @@ -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) + diff --git a/DDC/Core/Flow/Prim/Base.hs b/DDC/Core/Flow/Prim/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Prim/Base.hs @@ -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) + diff --git a/DDC/Core/Flow/Prim/DaConFlow.hs b/DDC/Core/Flow/Prim/DaConFlow.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Prim/DaConFlow.hs @@ -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 + diff --git a/DDC/Core/Flow/Prim/DaConPrim.hs b/DDC/Core/Flow/Prim/DaConPrim.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Prim/DaConPrim.hs @@ -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) + diff --git a/DDC/Core/Flow/Prim/KiConFlow.hs b/DDC/Core/Flow/Prim/KiConFlow.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Prim/KiConFlow.hs @@ -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) diff --git a/DDC/Core/Flow/Prim/OpFlow.hs b/DDC/Core/Flow/Prim/OpFlow.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Prim/OpFlow.hs @@ -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)) + diff --git a/DDC/Core/Flow/Prim/OpLoop.hs b/DDC/Core/Flow/Prim/OpLoop.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Prim/OpLoop.hs @@ -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)) diff --git a/DDC/Core/Flow/Prim/OpPrim.hs b/DDC/Core/Flow/Prim/OpPrim.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Prim/OpPrim.hs @@ -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 diff --git a/DDC/Core/Flow/Prim/OpStore.hs b/DDC/Core/Flow/Prim/OpStore.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Prim/OpStore.hs @@ -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)) + diff --git a/DDC/Core/Flow/Prim/TyConFlow.hs b/DDC/Core/Flow/Prim/TyConFlow.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Prim/TyConFlow.hs @@ -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 + diff --git a/DDC/Core/Flow/Prim/TyConPrim.hs b/DDC/Core/Flow/Prim/TyConPrim.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Prim/TyConPrim.hs @@ -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) + + + diff --git a/DDC/Core/Flow/Procedure.hs b/DDC/Core/Flow/Procedure.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Procedure.hs @@ -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 + diff --git a/DDC/Core/Flow/Process.hs b/DDC/Core/Flow/Process.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Process.hs @@ -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 () diff --git a/DDC/Core/Flow/Process/Operator.hs b/DDC/Core/Flow/Process/Operator.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Process/Operator.hs @@ -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 + diff --git a/DDC/Core/Flow/Process/Pretty.hs b/DDC/Core/Flow/Process/Pretty.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Process/Pretty.hs @@ -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) ] diff --git a/DDC/Core/Flow/Process/Process.hs b/DDC/Core/Flow/Process/Process.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Process/Process.hs @@ -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 + } + diff --git a/DDC/Core/Flow/Profile.hs b/DDC/Core/Flow/Profile.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Profile.hs @@ -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 + diff --git a/DDC/Core/Flow/Transform/Concretize.hs b/DDC/Core/Flow/Transform/Concretize.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Concretize.hs @@ -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 + diff --git a/DDC/Core/Flow/Transform/Extract.hs b/DDC/Core/Flow/Transform/Extract.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Extract.hs @@ -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) ] + diff --git a/DDC/Core/Flow/Transform/Extract/Intersperse.hs b/DDC/Core/Flow/Transform/Extract/Intersperse.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Extract/Intersperse.hs @@ -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))) + diff --git a/DDC/Core/Flow/Transform/Prep.hs b/DDC/Core/Flow/Transform/Prep.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Prep.hs @@ -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 + diff --git a/DDC/Core/Flow/Transform/Schedule.hs b/DDC/Core/Flow/Transform/Schedule.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Schedule.hs @@ -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 ] + + diff --git a/DDC/Core/Flow/Transform/Schedule/Nest.hs b/DDC/Core/Flow/Transform/Schedule/Nest.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Schedule/Nest.hs @@ -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 + diff --git a/DDC/Core/Flow/Transform/Schedule/SeriesEnv.hs b/DDC/Core/Flow/Transform/Schedule/SeriesEnv.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Schedule/SeriesEnv.hs @@ -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 + diff --git a/DDC/Core/Flow/Transform/Slurp.hs b/DDC/Core/Flow/Transform/Slurp.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Slurp.hs @@ -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]) + diff --git a/DDC/Core/Flow/Transform/Slurp/Alloc.hs b/DDC/Core/Flow/Transform/Slurp/Alloc.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Slurp/Alloc.hs @@ -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 diff --git a/DDC/Core/Flow/Transform/Slurp/Operator.hs b/DDC/Core/Flow/Transform/Slurp/Operator.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Slurp/Operator.hs @@ -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 + diff --git a/DDC/Core/Flow/Transform/Thread.hs b/DDC/Core/Flow/Transform/Thread.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Thread.hs @@ -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 + diff --git a/DDC/Core/Flow/Transform/Wind.hs b/DDC/Core/Flow/Transform/Wind.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Wind.hs @@ -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 ] + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ddc-core-flow.cabal b/ddc-core-flow.cabal new file mode 100644 --- /dev/null +++ b/ddc-core-flow.cabal @@ -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 +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 +