diff --git a/DDC/Core/Flow.hs b/DDC/Core/Flow.hs --- a/DDC/Core/Flow.hs +++ b/DDC/Core/Flow.hs @@ -6,11 +6,27 @@ ( -- * Language profile profile + -- * Driver + , Lifting (..) + , Config (..) + , defaultConfigVector + , defaultConfigKernel + , defaultConfigScalar + , Method (..) + , lowerModule + -- * Names , Name (..) + , KiConFlow (..) , TyConFlow (..) + , DaConFlow (..) + , OpControl (..) + , OpSeries (..) + , OpStore (..) + , OpVector (..) , PrimTyCon (..) , PrimArith (..) + , PrimVec (..) , PrimCast (..) -- * Name Parsing @@ -23,3 +39,4 @@ where import DDC.Core.Flow.Prim import DDC.Core.Flow.Profile +import DDC.Core.Flow.Lower diff --git a/DDC/Core/Flow/Compounds.hs b/DDC/Core/Flow/Compounds.hs --- a/DDC/Core/Flow/Compounds.hs +++ b/DDC/Core/Flow/Compounds.hs @@ -1,18 +1,30 @@ -- | Short-hands for constructing compound expressions. module DDC.Core.Flow.Compounds - ( module DDC.Core.Compounds.Simple + ( module DDC.Core.Flow.Exp.Simple.Compounds -- * Fragment specific kinds , kRate + , kProc -- * Fragment specific types + , isRateNatType + , isSeriesType + , isRateVecType + , isRefType + , isVectorType + , isProcessType , tTuple1, tTuple2, tTupleN - , tVector, tSeries, tSegd, tSel1, tSel2, tRef, tWorld + , tVector, tBuffer, tSeries, tRateVec, tSegd, tSel1, tSel2, tRef, tWorld , tRateNat + , tDown + , tTail + , tRateAppend, tRateCross + , tProcess + , tResize -- * Primtiive types - , tVoid, tBool, tNat, tInt, tWord + , tVoid, tBool, tNat, tInt, tWord, tFloat, tVec -- * Primitive literals and data constructors , xBool, dcBool @@ -21,25 +33,42 @@ , xTuple2, dcTuple2 , dcTupleN - -- * Flow operators + -- * Primitive Vec operators + , xvRep + , xvProj + , xvGather + , xvScatter + + -- * Series operators + , xProj , xRateOfSeries , xNatOfRateNat + , xNext, xNextC + , xDown + , xTail + , xSeriesOfRateVec - -- * Loop operators - , xLoopLoopN - , xLoopGuard + -- * Control operators + , xLoopN + , xGuard + , xSegment + , xSplit -- * Store operators - , xNew, xRead, xWrite - , xNewVector, xReadVector, xWriteVector, xNewVectorR, xNewVectorN - , xSliceVector - , xNext) + , xNew, xRead, xWrite + , xNewVector, xNewVectorR, xNewVectorN + , xReadVector, xReadVectorC + , xWriteVector, xWriteVectorC + , xTailVector + , xTruncVector) where import DDC.Core.Flow.Prim.KiConFlow import DDC.Core.Flow.Prim.TyConFlow import DDC.Core.Flow.Prim.TyConPrim import DDC.Core.Flow.Prim.DaConPrim -import DDC.Core.Flow.Prim.OpFlow -import DDC.Core.Flow.Prim.OpLoop +import DDC.Core.Flow.Prim.OpControl +import DDC.Core.Flow.Prim.OpConcrete +import DDC.Core.Flow.Prim.OpSeries import DDC.Core.Flow.Prim.OpStore -import DDC.Core.Compounds.Simple +import DDC.Core.Flow.Prim.OpPrim +import DDC.Core.Flow.Exp.Simple.Compounds diff --git a/DDC/Core/Flow/Context.hs b/DDC/Core/Flow/Context.hs --- a/DDC/Core/Flow/Context.hs +++ b/DDC/Core/Flow/Context.hs @@ -1,21 +1,7 @@ module DDC.Core.Flow.Context - (Context (..)) + ( module DDC.Core.Flow.Context.Base + , module DDC.Core.Flow.Context.FillPath ) 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) - +import DDC.Core.Flow.Context.Base +import DDC.Core.Flow.Context.FillPath diff --git a/DDC/Core/Flow/Context/Base.hs b/DDC/Core/Flow/Context/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Context/Base.hs @@ -0,0 +1,44 @@ + +module DDC.Core.Flow.Context.Base + (Context (..)) +where +import DDC.Type.Exp +import DDC.Core.Flow.Prim +import DDC.Core.Flow.Process.Operator + + +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 + , contextOps :: [Operator] + , contextInner :: [Context] } + + -- | A nested context created by a mkSel1# function. + | ContextSelect + { contextOuterRate :: Type Name + , contextInnerRate :: Type Name + , contextFlags :: Bound Name + , contextSelector :: Bind Name + , contextOps :: [Operator] + , contextInner :: [Context] } + + + -- | A nested context created by a mkSegd# function. + | ContextSegment + { contextOuterRate :: Type Name + , contextInnerRate :: Type Name + , contextLens :: Bound Name + , contextSegd :: Bind Name + , contextOps :: [Operator] + , contextInner :: [Context] } + + | ContextAppend + { contextRate1 :: Type Name + , contextInner1 :: Context + , contextRate2 :: Type Name + , contextInner2 :: Context } + deriving Show + + diff --git a/DDC/Core/Flow/Context/FillPath.hs b/DDC/Core/Flow/Context/FillPath.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Context/FillPath.hs @@ -0,0 +1,148 @@ + +module DDC.Core.Flow.Context.FillPath + ( FillMap, FillPath + , pathsOfFills + , getAccForPath + , getAcc + , isSimple + , isNone ) +where +import DDC.Type.Exp +import DDC.Core.Flow.Prim +import DDC.Core.Flow.Process.Operator +import DDC.Core.Flow.Context.Base + +import qualified Data.Map as Map +import Control.Monad + + +type FillMap = Map.Map Name (FillPath, Type Name) + +data FillPath + = PathNone + | PathRate (Type Name) + | PathSelect (Bound Name) + | PathSegment (Bound Name) + | PathAppend FillPath FillPath + deriving (Eq, Show) + + +pathsOfFills :: Context -> Maybe FillMap +pathsOfFills ctx + = go ctx Map.empty + where + go c@ContextAppend{} _ + = do m1 <- go (contextInner1 c) Map.empty + m2 <- go (contextInner2 c) Map.empty + return $ Map.unionWith merge + (Map.map appl m1) + (Map.map appr m2) + + go c m + = do m' <- insertFillsNoDupes (contextOps c) (path c) m + foldM (flip go) m' (contextInner c) + + appl (p,t) + = (PathAppend p PathNone, t) + appr (p,t) + = (PathAppend PathNone p, t) + + merge (PathAppend PathNone _, t) (PathAppend _ PathNone, _) + = (PathNone, t) + merge (PathAppend l _, t) (PathAppend _ r, _) + = (PathAppend l r, t) + merge _ _ + = error "ddc-core-flow.pathsOfFills: impossible!" + + path c@ContextRate{} + = PathRate $ contextRate c + path c@ContextSelect{} + = PathSelect $ contextFlags c + path c@ContextSegment{} + = PathSegment $ contextLens c + path ContextAppend{} + = PathAppend PathNone PathNone + + + insertFillsNoDupes ops p m + = foldM (insert1 p) m ops + + insert1 p m OpFill{ opTargetVector = UName n + , opElemType = ty } + = case Map.lookup n m of + Nothing + -> Just (Map.insert n (p,ty) m) + Just _ + -> Nothing + insert1 _ m _ + = Just m + + +isPrefixOf :: FillPath -> FillPath -> Bool +isPrefixOf PathNone _ + = True +isPrefixOf (PathAppend h i) (PathAppend j k) + = h == j && isPrefixOf i k + || i == PathNone && k == PathNone && isPrefixOf h j +isPrefixOf a b + = a == b + +isNone :: FillPath -> Bool +isNone PathNone + = True +isNone (PathAppend i j) + = isNone i && isNone j +isNone _ + = False + +-- A simple fill path has only one place it's filling, and it's just a rate with no select or segment +isSimple :: FillPath -> Bool +isSimple (PathAppend i j) + = isSimple i && isNone j + || isSimple j && isNone i +isSimple (PathRate _) + = True +isSimple _ + = False + + + +getAccForPath :: FillMap -> FillPath -> Maybe Name +getAccForPath m fp + = case Map.minViewWithKey $ Map.filter search m of + Nothing -> Nothing + Just ((k,_),_) -> Just k + where + search (fp', _) + = isPrefixOf fp fp' + +-- If acc is Nothing, you can just use the current index ^0 +getAcc :: FillMap -> Name -> Maybe Name +getAcc m n + = case Map.lookup n m of + Nothing + -> Nothing -- ??? + Just (fp, _) + -> if isSimple fp + then Nothing + else getAccForPath m fp + +-- I don't think this actually gives us the fewest number of accumulators. +-- Depending on the ordering of the map, maybe we'd have +-- +-- [ h = App a None; +-- i = App a None; +-- j = App a b; +-- k = App a c ] +-- +-- here, @h@ and @i@ will be given the same accumulator, but @j@ and @k@ need separate +-- accumulators: three accumulators in total. +-- +-- If the order were different, such as +-- [ j = App a b; +-- h = App a None; +-- i = App a None; +-- k = App a c ] +-- then searching for @h@ or @i@ would find @j@, and we would end up with only two accumulators, @j@ and @k@. +-- + diff --git a/DDC/Core/Flow/Convert.hs b/DDC/Core/Flow/Convert.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Convert.hs @@ -0,0 +1,190 @@ + +-- | Conversion of Flow to Tetra +-- +module DDC.Core.Flow.Convert + ( tetraOfFlowModule ) +where + +import DDC.Core.Flow.Convert.Base +import DDC.Core.Flow.Convert.Type +import DDC.Core.Flow.Convert.Exp +import DDC.Core.Exp.Annot +import DDC.Core.Module +import DDC.Control.Check + +import qualified DDC.Core.Flow.Prim as F +import qualified DDC.Core.Salt.Name as T +import qualified DDC.Core.Salt.Compounds as T + +import DDC.Core.Salt.Convert (initRuntime) +import DDC.Core.Salt.Runtime (Config(..)) + +import qualified Data.Set as S + + +tetraOfFlowModule :: Module a F.Name -> Either Error (Module a T.Name) +tetraOfFlowModule mm + = evalCheck (S.empty, S.empty) + $ convertM mm + +convertM :: Module a F.Name -> ConvertM (Module a T.Name) +convertM mm + = do + -- Convert signatures of imported functions. + tsImportT' <- mapM convertImportNameTypeM $ moduleImportTypes mm + tsImportV' <- mapM convertImportNameValueM $ moduleImportValues mm + + let tsImportV'rest = + [ ( T.NameVar "getFieldOfBoxed" + , ImportValueSea "getFieldOfBoxed" + $ tForalls [kRegion, kData] + $ \[r,d] -> T.tPtr r T.tObj `tFun` T.tNat `tFun` d) + + , ( T.NameVar "setFieldOfBoxed" + , ImportValueSea "setFieldOfBoxed" + $ tForalls [kRegion, kData] + $ \[r,d] -> T.tPtr r T.tObj `tFun` T.tNat `tFun` d `tFun` T.tVoid) + + , ( T.NameVar "allocBoxed" + , ImportValueSea "allocBoxed" + $ tForalls [kRegion ] + $ \[r ] -> T.tTag `tFun` T.tNat `tFun` T.tPtr r T.tObj) + ] + + -- Convert signatures of exported functions. + tsExportT' <- mapM convertExportM + $ moduleExportTypes mm + + tsExportV' <- mapM convertExportM + $ moduleExportValues mm + + -- Convert the body of the module + body' <- convertX $ moduleBody mm + + -- Build the output module. + let mm_tetra + = ModuleCore + { moduleName = moduleName mm + , moduleIsHeader = moduleIsHeader mm + + , moduleExportTypes = tsExportT' + , moduleExportValues = tsExportV' + + , moduleImportTypes = tsImportT' + , moduleImportCaps = [] + , moduleImportValues = tsImportV' ++ tsImportV'rest + + -- We're only using whole module compilation for + -- flow programs, so there aren't any imports. + , moduleImportDataDefs = [] + , moduleImportTypeDefs = [] + + , moduleDataDefsLocal = [] + , moduleTypeDefsLocal = [] + + , moduleBody = body' } + + -- Initialise the salt heap. + -- Hardcode this for now, because eventually this will target tetra. + mm_init <- case initRuntime (Config 10000) mm_tetra of + Nothing -> return mm_tetra + Just mm' -> return mm' + + return $ mm_init + + +--------------------------------------------------------------------------------------------------- +-- | Convert an export spec. +convertExportM + :: (F.Name, ExportSource F.Name (Type F.Name)) + -> ConvertM (T.Name, ExportSource T.Name (Type T.Name)) + +convertExportM (n, esrc) + = do n' <- convertName n + esrc' <- convertExportSourceM esrc + return (n', esrc') + + +-- Convert an export source. +convertExportSourceM + :: ExportSource F.Name (Type F.Name) + -> ConvertM (ExportSource T.Name (Type T.Name)) + +convertExportSourceM esrc + = case esrc of + ExportSourceLocal n t + -> do n' <- convertName n + t' <- convertType t + return $ ExportSourceLocal n' t' + + ExportSourceLocalNoType n + -> do n' <- convertName n + return $ ExportSourceLocalNoType n' + + +--------------------------------------------------------------------------------------------------- +-- | Convert an import spec. +convertImportNameTypeM + :: (F.Name, ImportType F.Name (Type F.Name)) + -> ConvertM (T.Name, ImportType T.Name (Type T.Name)) + +convertImportNameTypeM (n, isrc) + = do n' <- convertImportNameM n + isrc' <- convertImportTypeM isrc + return (n', isrc') + + +-- | Convert an import spec. +convertImportNameValueM + :: (F.Name, ImportValue F.Name (Type F.Name)) + -> ConvertM (T.Name, ImportValue T.Name (Type T.Name)) + +convertImportNameValueM (n, isrc) + = do n' <- convertImportNameM n + isrc' <- convertImportValueM isrc + return (n', isrc') + + +-- | Convert an imported name. +-- These can be variable names for values, +-- or variable or constructor names for type imports. +convertImportNameM :: F.Name -> ConvertM T.Name +convertImportNameM n + = case n of + F.NameVar str -> return $ T.NameVar str + F.NameCon str -> return $ T.NameCon str + _ -> throw $ ErrorInvalidBinder n + + +-- | Convert an import source. +convertImportTypeM + :: ImportType F.Name (Type F.Name) + -> ConvertM (ImportType T.Name (Type T.Name)) + +convertImportTypeM isrc + = case isrc of + ImportTypeAbstract t + -> do t' <- convertType t + return $ ImportTypeAbstract t' + + ImportTypeBoxed t + -> do t' <- convertType t + return $ ImportTypeBoxed t' + + +-- | Convert an import value spec. +convertImportValueM + :: ImportValue F.Name (Type F.Name) + -> ConvertM (ImportValue T.Name (Type T.Name)) + +convertImportValueM isrc + = case isrc of + ImportValueModule mn n t _ + -> do n' <- convertName n + t' <- convertType t + return $ ImportValueModule mn n' t' Nothing + + ImportValueSea str t + -> do t' <- convertType t + return $ ImportValueSea str t' + diff --git a/DDC/Core/Flow/Convert/Base.hs b/DDC/Core/Flow/Convert/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Convert/Base.hs @@ -0,0 +1,88 @@ + +module DDC.Core.Flow.Convert.Base + ( ConvertM + , Error (..) + , withRateXLAM, isRateXLAM + , withSuspFns, isSuspFn) +where +import DDC.Data.Pretty +import DDC.Core.Exp.Annot +import DDC.Core.Flow.Prim as F +import qualified DDC.Control.Check as G + +import qualified Data.Set as S +import Data.Maybe + +-- | Conversion Monad +-- State contains +-- * names of function that have been converted to Suspended computations. +-- whenever these are called, we need to add a "run" cast. +-- * names of rate XLAMs that have been removed. +-- any reference to these must also be removed. +type ConvertM x = G.CheckM (S.Set F.Name, S.Set F.Name) Error x + + +withRateXLAM :: Bind F.Name -> ConvertM a -> ConvertM a +withRateXLAM r c + | Just r' <- takeNameOfBind r + = do (fs,rs) <- G.get + G.put (fs, S.insert r' rs) + val <- c + G.put (fs, rs) + return $ val + | otherwise + = c + + +isRateXLAM :: F.Name -> ConvertM Bool +isRateXLAM r + = do (_,rs) <- G.get + return $ S.member r rs + + +withSuspFns :: [Bind F.Name] -> ConvertM a -> ConvertM a +withSuspFns bs c + = do (fs,rs) <- G.get + let ns = catMaybes $ map takeNameOfBind bs + G.put (S.union (S.fromList ns) fs, rs) + val <- c + G.put (fs, rs) + return $ val + +isSuspFn :: F.Name -> ConvertM Bool +isSuspFn f + = do (fs,_) <- G.get + return $ S.member f fs + + +-- | Things that can go wrong during the conversion. +data Error + -- | An invalid name used in a binding position + = ErrorInvalidBinder F.Name + + -- | A partially applied primitive, such as "Series" + | ErrorPartialPrimitive F.Name + + -- | Something we can't convert, like "runKernel0#", + -- but that shouldn't be created + | ErrorNotSupported F.Name + + -- | Found an unexpected type sum. + | ErrorUnexpectedSum + + +instance Pretty Error where + ppr err + = case err of + ErrorInvalidBinder n + -> vcat [ text "Invalid name used in binder '" <> ppr n <> text "'."] + + ErrorPartialPrimitive n + -> vcat [ text "Cannot convert primitive " <> ppr n <> text "." ] + + ErrorNotSupported n + -> vcat [ text "Cannot convert " <> ppr n <> text ", as it shouldn't be generated by flow transforms." ] + + ErrorUnexpectedSum + -> vcat [ text "Unexpected type sum."] + diff --git a/DDC/Core/Flow/Convert/Exp.hs b/DDC/Core/Flow/Convert/Exp.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Convert/Exp.hs @@ -0,0 +1,465 @@ + +-- | Conversion of Flow expressions to Tetra expressions +-- This only handles the subset of flow that occurs after lowering. +module DDC.Core.Flow.Convert.Exp + ( convertX ) +where + +import DDC.Core.Flow.Convert.Base +import DDC.Core.Flow.Convert.Type +import DDC.Core.Exp.Annot +import DDC.Type.Transform.BoundT + +import qualified DDC.Core.Flow.Prim as F +import qualified DDC.Core.Flow.Compounds as F + +import qualified DDC.Core.Salt.Name as T +import qualified DDC.Core.Salt.Compounds as T +import qualified DDC.Core.Salt.Env as T + +import Control.Monad + + +convertX :: Exp a F.Name -> ConvertM (Exp a T.Name) +convertX xx + -- Remove any /\(k : Rate). They are not needed any more. + | XLAM _ b x <- xx + , typeOfBind b == F.kRate + = withRateXLAM b $ removeXLAM b <$> convertX x + + -- Operators that just need a region added as first argument + | Just (op, xs@(_:_)) <- takeXPrimApps xx + = case op of + F.NameOpStore F.OpStoreNew + | [ ty, val ] <- xs + , Just tY <- takeXType ty + -> do tY' <- convertType tY + val' <- convertX val + return $ allocRef anno tY' val' + + F.NameOpStore F.OpStoreRead + | [ ty, ref ] <- xs + -> do ty' <- convertX ty + ref' <- convertX ref + + return $ mk (T.PrimStore T.PrimStorePeek) + [ xRTop anno, ty', ref', T.xNat anno 0 ] + + F.NameOpStore F.OpStoreWrite + | [ ty, ref, val ] <- xs + -> do ty' <- convertX ty + ref' <- convertX ref + val' <- convertX val + + return + $ XLet anno + (LLet (BNone T.tVoid) + $ mk (T.PrimStore T.PrimStorePoke) + [ xRTop anno, ty', ref', T.xNat anno 0, val' ]) + (XCon anno $ DaConUnit) + + + -- natOfRateNat becomes a noop, as RateNats become Nats. + F.NameOpConcrete F.OpConcreteNatOfRateNat + | [ _r, n ] <- xs + -> convertX n + + F.NameOpConcrete (F.OpConcreteNext 1) + | [t, _r, v, i] <- xs + -> do v' <- convertX v + i' <- convertX i + t' <- convertX t + return $ mk (T.PrimStore T.PrimStorePeek) + [ xRTop anno, t', v' + , mk (T.PrimArith T.PrimArithMul) + [ XType anno T.tNat, i' + , mk (T.PrimStore T.PrimStoreSize) [t'] ] ] + + -- vlength# [t] vec + -- becomes a projection + F.NameOpVector F.OpVectorLength + | [xt, v] <- xs + , Just t <- takeXType xt + -> do t' <- convertType t + v' <- convertX v + return $ xVecLen t' v' + + -- vwrite# [t] buf ix val + F.NameOpStore (F.OpStoreWriteVector 1) + | [xt, buf, ix, val] <- xs + , Just t <- takeXType xt + -> do t' <- convertType t + buf' <- convertX buf + ix' <- convertX ix + val' <- convertX val + + return + $ XLet anno + (LLet (BNone T.tVoid) + $ mk (T.PrimStore T.PrimStorePoke) + [ xRTop anno + , XType anno t' + , buf' + , mk (T.PrimArith T.PrimArithMul) + [ XType anno T.tNat, ix' + , mk (T.PrimStore T.PrimStoreSize) [XType anno t'] ] + , val' ]) + (XCon anno DaConUnit) + + -- vbuf# [t] vec + F.NameOpStore F.OpStoreBufOfVector + | [xt, vec] <- xs + , Just t <- takeXType xt + -> do t' <- convertType t + vec' <- convertX vec + + return + $ xVecPtr t' vec' + + + -- vnew# [t] len + F.NameOpStore F.OpStoreNewVector + | [xt, sz] <- xs + , Just t <- takeXType xt + -> do t' <- convertType t + sz' <- convertX sz + + let lenR = allocRef anno T.tNat sz' + datR = allocPtr anno t' sz' + tup = allocTupleN anno [(tRef rTop T.tNat, lenR), (T.tPtr rTop t', datR)] + return tup + + -- vtrunc# [t] len vec + F.NameOpStore F.OpStoreTruncVector + | [xt, sz, v] <- xs + , Just t <- takeXType xt + -> do _t' <- convertType t + sz' <- convertX sz + v' <- convertX v + + return + $ XLet anno + (LLet (BNone T.tVoid) + $ mk (T.PrimStore T.PrimStorePoke) + [ xRTop anno + , XType anno T.tNat + , projTuple anno v' 0 (T.tPtr rTop T.tNat) + , T.xNat anno 0 + , sz' ]) + (XCon anno $ DaConUnit) + + F.NameOpSeries F.OpSeriesRunProcess + | [proc] <- xs + -> do proc' <- convertX proc + return + $ XApp anno proc' $ XCon anno $ DaConUnit + +{- + -- runKernelN# [ty1]...[tyN] v1...vN proc + -- becomes + -- proc (length v1) (ptrOfVec v1) ... (ptrOfVec vN) + F.NameOpConcrete (F.OpConcreteRunKernel n) + | (xts, xs') <- splitAt n xs + , Just ts <- mapM takeXType xts + , (vs, [proc]) <- splitAt n xs' + -> do vs' <- mapM convertX vs + ts' <- mapM convertType ts + + proc' <- convertX proc + + case (vs',ts') of + ((v':_), (t':_)) + -> return + $ XLet anno (LLet (BNone tUnit) + ( xApps anno proc' + (xVecLen t' v' : zipWith xVecPtr ts' vs'))) + true + (_, _) + -> throw $ ErrorNotSupported op +-} + + _ + -> case takeXApps xx of + Just (f,args) -> convertApp f args + Nothing -> error "ddc-core-flow.convertX: impossible!" + + | Just + (DaConPrim (F.NameDaConFlow (F.DaConFlowTuple n)) _ + , args) <- takeXConApps xx + , length args == n * 2 + , (xts, xs) <- splitAt n args + , Just ts <- mapM takeXType xts + = do ts' <- mapM convertType ts + xs' <- mapM convertX xs + return + $ allocTupleN anno (ts' `zip` xs') + + | Just (f, args@(_:_)) <- takeXApps xx + = convertApp f args + + | XCase _ x + [AAlt (PData (DaConPrim (F.NameDaConFlow (F.DaConFlowTuple n)) _) bs) x1] + <- xx + , length bs == n + = do x' <- convertX x + bs' <- mapM convertBind bs + x1' <- convertX x1 + return + $ xLets anno + [ LLet b (projTuple anno x' i $ typeOfBind b) + | (b,i) <- bs' `zip` [0..] ] + x1' + + -- otherwise just boilerplate recursion + | otherwise + = case xx of + XVar a b + -> XVar a <$> convertBound b + XCon a c + -> XCon a <$> convertDaCon c + XLAM a b x + -> XLAM a <$> convertBind b <*> convertX x + XLam a b x + -> XLam a <$> convertBind b <*> convertX x + XApp a p q + -> XApp a <$> convertX p <*> convertX q + XLet a ls x + -> let bs = valwitBindsOfLets ls + in withSuspFns bs $ XLet a <$> convertLets ls <*> convertX x + XCase a x as + -> XCase a<$> convertX x <*> mapM convertAlt as + XCast a c x + -> XCast a<$> convertCast c <*> convertX x + XType a t + -> XType a<$> convertType t + XWitness a w + -> XWitness a <$> convertWit w + where + anno = annotOfExp xx + + mk = prim anno + +prim anno n args + = let t = T.typeOfPrimOp n + in xApps anno (XVar anno (UPrim (T.NamePrimOp n) t)) args + + +convertApp :: Exp a F.Name -> [Exp a F.Name] -> ConvertM (Exp a T.Name) +convertApp f args + = do f' <- convertX f + -- filter out any type args that reference deleted XLAMs + let checkT arg + | XType _ (TVar (UName n)) <- arg + = not <$> isRateXLAM n + | otherwise + = return True + args' <- filterM checkT args + >>= mapM convertX + + let checkF + | XVar _ (UName n) <- f + = isSuspFn n + | otherwise + = return False + + isSusp <- checkF + if isSusp + then return $ xApps anno f' args' + else return $ xApps anno f' args' + where + anno = annotOfExp f + +convertDaCon + :: DaCon F.Name (Type F.Name) + -> ConvertM (DaCon T.Name (Type T.Name)) +convertDaCon dd + = case dd of + DaConUnit + -> return DaConUnit + DaConPrim n t + -> DaConPrim <$> convertName n <*> convertType t + DaConBound n + -> DaConBound <$> convertName n + +convertLets :: Lets a F.Name -> ConvertM (Lets a T.Name) +convertLets ll + = case ll of + + LLet b x + -> LLet <$> convertBind b <*> convertX x + + LRec bxs + -> LRec <$> mapM (both convertBind convertX) bxs + + LPrivate rs t ws + -> LPrivate <$> mapM convertBind rs + <*> liftMaybe convertType t -- ?? + <*> mapM convertBind ws + + where + liftMaybe f m + = case m of + Just a -> Just <$> f a + Nothing -> return Nothing + + both f g + = \(a,b) -> (,) <$> f a <*> g b + +convertAlt :: Alt a F.Name -> ConvertM (Alt a T.Name) +convertAlt aa + = case aa of + AAlt p x + -> AAlt <$> convertPat p <*> convertX x + +convertPat :: Pat F.Name -> ConvertM (Pat T.Name) +convertPat pp + = case pp of + PDefault + -> return $ PDefault + PData dc bs + -> PData <$> convertDaCon dc <*> mapM convertBind bs + +convertCast :: Cast a F.Name -> ConvertM (Cast a T.Name) +convertCast cc + = case cc of + CastWeakenEffect et + -> CastWeakenEffect <$> convertType et + + CastPurify w + -> CastPurify <$> convertWit w + + CastBox + -> return $ CastBox + + CastRun + -> return $ CastRun + + +convertWit :: Witness a F.Name -> ConvertM (Witness a T.Name) +convertWit = error "ddc-core-flow.convertWit: cannot convert witness from core flow program" + + +-- | When replacing @/\(b : Rate). x@ with @x@, if @b@ is a de bruijn index then any type vars in @x@ must be lowered. +-- @b@ must not be mentioned in @x@. +removeXLAM :: Bind F.Name -> Exp a T.Name -> Exp a T.Name +removeXLAM b t + = case b of + BAnon _ + -> lowerT 1 t + _ + -> t + + +-- | Type of the top-level region. +xRTop :: a -> Exp a T.Name +xRTop a = XType a rTop + +-- | Get the Nat# of length from a Vector +xVecLen :: Type T.Name -> Exp a T.Name -> Exp a T.Name +xVecLen _t x + = prim anno (T.PrimStore T.PrimStorePeek) + [ xRTop anno, XType anno T.tNat + , projTuple anno x 0 (T.tPtr rTop T.tNat) + , T.xNat anno 0 ] + where + anno = annotOfExp x + +-- | Get the pointer to the data from a Vector +xVecPtr :: Type T.Name -> Exp a T.Name -> Exp a T.Name +xVecPtr t x + = projTuple anno x 1 (T.tPtr rTop t) + where + anno = annotOfExp x + +allocRef :: a -> Type T.Name -> Exp a T.Name -> Exp a T.Name +allocRef anno tY val + = let ty = XType anno tY + + sz = prim anno (T.PrimStore T.PrimStoreSize) [ty] + addr = prim anno (T.PrimStore T.PrimStoreAlloc) [sz] + ptr = prim anno (T.PrimStore T.PrimStoreMakePtr) + [ xRTop anno, ty, addr ] + + ll = LLet (BAnon $ T.tPtr rTop tY) + ptr + + ptr' = XVar anno $ UIx 0 + poke = prim anno (T.PrimStore T.PrimStorePoke) + [ xRTop anno, ty, ptr', T.xNat anno 0, val ] + in XLet anno ll + $ XLet anno (LLet (BNone T.tVoid) poke) + ptr' + +allocPtr :: a -> Type T.Name -> Exp a T.Name -> Exp a T.Name +allocPtr anno tY elts + = let ty = XType anno tY + + sz = prim anno (T.PrimStore T.PrimStoreSize) [ty] + addr = prim anno (T.PrimStore T.PrimStoreAlloc) + [ prim anno (T.PrimArith T.PrimArithMul) + [ XType anno T.tNat, elts, sz] ] + ptr = prim anno (T.PrimStore T.PrimStoreMakePtr) + [ xRTop anno, ty, addr ] + + in ptr + + +unptr :: Type T.Name -> Type T.Name +unptr t + | Just (_,t') <- T.takeTPtr t + = t' + | otherwise + = t + +trybox :: a -> Type T.Name -> Exp a T.Name -> Exp a T.Name +trybox anno t x + -- Already a pointer, don't bother + | Just (_,_) <- T.takeTPtr t + = x + | otherwise + = allocRef anno t x + +tryunbox :: a -> Type T.Name -> Exp a T.Name -> Exp a T.Name +tryunbox anno t x + -- Already a pointer, don't bother + | Just (_,_) <- T.takeTPtr t + = x + | otherwise + = prim anno (T.PrimStore T.PrimStorePeek) + [ xRTop anno, XType anno t + , x, T.xNat anno 0 ] + +projTuple :: a -> Exp a T.Name -> Integer -> Type T.Name -> Exp a T.Name +projTuple anno x i t + = let t' = unptr t + in tryunbox anno t + $ castPtr anno t' T.tObj + $ xApps anno (XVar anno $ UName $ T.NameVar "getFieldOfBoxed") + [ xRTop anno, XType anno $ T.tPtr rTop T.tObj, x, T.xNat anno i ] + + +allocTupleN :: a -> [(Type T.Name, Exp a T.Name)] -> Exp a T.Name +allocTupleN anno txs + = let tup = xApps anno (XVar anno $ UName $ T.NameVar "allocBoxed") + [ xRTop anno, T.xTag anno 0, T.xNat anno (fromIntegral $ length txs) ] + + tup' = XVar anno $ UIx 0 + + set i t x + = let t' = unptr t + x' = trybox anno t x + in xApps anno (XVar anno $ UName $ T.NameVar "setFieldOfBoxed") + [ xRTop anno, XType anno (T.tPtr rTop T.tObj), tup', T.xNat anno i + , castPtr anno T.tObj t' x' ] + + in XLet anno (LLet (BAnon $ T.tPtr rTop T.tObj) tup) + $ xLets anno + [LLet (BNone T.tVoid) (set i t x) | ((t,x), i) <- txs `zip` [0..]] + tup' + + +castPtr :: a -> Type T.Name -> Type T.Name -> Exp a T.Name -> Exp a T.Name +castPtr anno to from x + = prim anno (T.PrimStore T.PrimStoreCastPtr) + [ xRTop anno, XType anno to, XType anno from, x ] + diff --git a/DDC/Core/Flow/Convert/Type.hs b/DDC/Core/Flow/Convert/Type.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Convert/Type.hs @@ -0,0 +1,209 @@ + +-- | Conversion of Flow types to Tetra types +-- This only handles the subset of flow that occurs after lowering. +module DDC.Core.Flow.Convert.Type + ( convertType + , convertBind + , convertBound + , convertName + , rTop + , tVec + , tRef ) +where +import DDC.Core.Flow.Convert.Base +import DDC.Core.Exp.Annot +import DDC.Control.Check (throw) +import DDC.Type.Transform.BoundT + +import qualified DDC.Core.Flow.Prim as F +import qualified DDC.Core.Flow.Compounds as F + +import qualified DDC.Core.Salt.Name as T +import qualified DDC.Core.Salt.Compounds as T + + + +tRef :: Type T.Name -> Type T.Name -> Type T.Name +tRef = T.tPtr + +tVec :: Type T.Name +tVec = T.tPtr rTop T.tObj + + +-- | Convert types from Flow to Tetra. +-- +-- The majority of type conversions are just replacing one name with another, +-- so these are performed in @convertName@. +-- +-- Others require removing arguments or adding regions are performed here, before name conversion: +-- * Rate foralls are removed +-- * @Series k a@ becomes @Ptr# rTop a@ +-- * @RateNat k@ becomes @Nat#@ +-- * @Ref a@ becomes @Ref# rTop a@ +-- * @a->b->c@ becomes @a -> b -> S (Read rT + Write rT + Alloc rT) c@ +-- +convertType :: Type F.Name -> ConvertM (Type T.Name) +convertType tt + -- Remove [k : Rate] foralls. + | TForall b t <- tt + , typeOfBind b == F.kRate + = removeForall b <$> convertType t + + -- Convert @Vector a@ to @Tuple2# (Ptr# a) (Ref# Nat#)@ + | Just (F.NameTyConFlow F.TyConFlowVector, [tA]) <- takePrimTyConApps tt + = do _tA' <- convertType tA + return $ tVec -- T.tTupleN [T.tPtr rTop tA', T.tRef rTop T.tNat] + + -- Convert @Buffer a@ to @Ptr# a@ + | Just (F.NameTyConFlow F.TyConFlowBuffer, [tA]) <- takePrimTyConApps tt + = do tA' <- convertType tA + return $ T.tPtr rTop tA' + + -- Convert @TupleN#@ to @Ptr# rTop Obj@ + | Just (F.NameTyConFlow (F.TyConFlowTuple _), ts) <- takePrimTyConApps tt + = do -- Might as well attempt to convert the types, just so we know they're valid + mapM_ convertType ts + return $ tVec + + -- Convert @Series k a@ to just @Ptr# a@ + | Just (F.NameTyConFlow F.TyConFlowSeries, [_K, tA]) <- takePrimTyConApps tt + = T.tPtr rTop <$> convertType tA + + -- Convert @RateNat k@ to @Nat#@ + | Just (F.NameTyConFlow F.TyConFlowRateNat, [_K]) <- takePrimTyConApps tt + = return $ T.tNat + + -- Convert Refs + | Just (F.NameTyConFlow F.TyConFlowRef, [tA]) <- takePrimTyConApps tt + = tRef rTop <$> convertType tA + + -- Convert normal TFuns to TFunECs with pure and empty. why? + | (args@(_:_), res) <- takeTFunArgResult tt + = do args' <- mapM convertType args + res' <- convertType res + + return $ foldr tFun res' args' + + + -- For other primitives, convertName will handle convert them + | otherwise + = case tt of + TVar b + -> TVar <$> convertBound b + TCon c + -> TCon <$> convertTyCon c + + TAbs b t + -> TAbs <$> convertBind b <*> convertType t + + TApp p q + -> TApp <$> convertType p <*> convertType q + + TForall b t + -> TForall <$> convertBind b <*> convertType t + + TSum _t + -> return $ TSum $ TypeSumBot $ kData -- throw $ ErrorUnexpectedSum + + +convertBind :: Bind F.Name -> ConvertM (Bind T.Name) +convertBind b + = case b of + BNone t -> BNone <$> convertType t + BAnon t -> BAnon <$> convertType t + BName n t -> BName <$> convertName n <*> convertType t + + +convertBound :: Bound F.Name -> ConvertM (Bound T.Name) +convertBound b + = case b of + UIx i -> return $ UIx i + UName n -> UName <$> convertName n + UPrim n t -> UPrim <$> convertName n <*> convertType t + + + + +convertName :: F.Name -> ConvertM T.Name +convertName nn + = case nn of + F.NameVar n + -> return $ T.NameVar n + F.NameVarMod n x + -> flip T.NameExt x <$> convertName n + F.NameCon n + -> return $ T.NameCon n + + F.NameKiConFlow _ + -> throw $ ErrorPartialPrimitive nn + + F.NameTyConFlow tf + -> case tf of + -- F.TyConFlowTuple n + -- -> return $ T.NameTyConTetra $ T.TyConTetraTuple n + + -- Vector, Series, RateNat and Ref are handled elsewhere as arguments must be changed + _ + -> throw $ ErrorPartialPrimitive nn + + -- Machine primitives ------------------ + -- F.NamePrimTyCon T.PrimTyConBool + -- -> return $ T.NamePrimTyCon T.PrimTyConNat + + F.NamePrimTyCon p + -> return $ T.NamePrimTyCon p + + F.NamePrimArith p + -> return $ T.NamePrimOp $ T.PrimArith p + + F.NamePrimCast p + -> return $ T.NamePrimOp $ T.PrimCast p + + -- Literals ----------------------------- + F.NameLitBool b + -> return $ T.NamePrimLit (T.PrimLitBool b) + + F.NameLitNat l + -> return $ T.NamePrimLit (T.PrimLitNat l) + + F.NameLitInt l + -> return $ T.NamePrimLit (T.PrimLitInt l) + + F.NameLitWord l k + -> return $ T.NamePrimLit (T.PrimLitWord l k) + + _ -> throw $ ErrorInvalidBinder nn + + +convertTyCon :: TyCon F.Name -> ConvertM (TyCon T.Name) +convertTyCon tc + = case tc of + TyConSort s + -> return $ TyConSort s + TyConKind k + -> return $ TyConKind k + TyConWitness w + -> return $ TyConWitness w + TyConSpec s + -> return $ TyConSpec s + TyConBound b k + -> TyConBound <$> convertBound b <*> convertType k + TyConExists i k + -> TyConExists i <$> convertType k + + +-- | When replacing @Forall b t@ with @t@, if @b@ is a de bruijn +-- index then @t@ must be lowered. @b@ must not be mentioned in @t@. +removeForall :: Bind F.Name -> Type T.Name -> Type T.Name +removeForall b t + = case b of + BAnon _ + -> lowerT 1 t + _ + -> t + + +-- | Top region +rTop :: Type T.Name +rTop = TVar $ UName $ T.NameVar "rT" + diff --git a/DDC/Core/Flow/Env.hs b/DDC/Core/Flow/Env.hs --- a/DDC/Core/Flow/Env.hs +++ b/DDC/Core/Flow/Env.hs @@ -32,52 +32,57 @@ primDataDefs :: DataDefs Name primDataDefs = fromListDataDefs - -- Primitive ----------------------------------------------- - $ -- Bool# - [ DataDef (NamePrimTyCon PrimTyConBool) + $ -- Primitive ----------------------------------------------- + -- Bool# + [ makeDataDefAlg (NamePrimTyCon PrimTyConBool) [] (Just [ (NameLitBool True, []) , (NameLitBool False, []) ]) -- Nat# - , DataDef (NamePrimTyCon PrimTyConNat) [] Nothing + , makeDataDefAlg (NamePrimTyCon PrimTyConNat) [] Nothing -- Int# - , DataDef (NamePrimTyCon PrimTyConInt) [] Nothing + , makeDataDefAlg (NamePrimTyCon PrimTyConInt) [] Nothing + -- Float32# + , makeDataDefAlg (NamePrimTyCon (PrimTyConFloat 32)) [] Nothing + + -- Float64# + , makeDataDefAlg (NamePrimTyCon (PrimTyConFloat 64)) [] Nothing + -- WordN# - , DataDef (NamePrimTyCon (PrimTyConWord 64)) [] Nothing - , DataDef (NamePrimTyCon (PrimTyConWord 32)) [] Nothing - , DataDef (NamePrimTyCon (PrimTyConWord 16)) [] Nothing - , DataDef (NamePrimTyCon (PrimTyConWord 8)) [] Nothing + , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 64)) [] Nothing + , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 32)) [] Nothing + , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 16)) [] Nothing + , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 8)) [] Nothing -- Flow ----------------------------------------------------- - -- Vector - , DataDef + , makeDataDefAbs (NameTyConFlow TyConFlowVector) - [kRate, kData] - (Just []) + [BAnon kRate, BAnon kData] -- Series - , DataDef + , makeDataDefAbs (NameTyConFlow TyConFlowSeries) - [kRate, kData] - (Just []) + [BAnon kRate, BAnon kData] ] -- Tuple -- Hard-code maximum tuple arity to 32. - ++ [ makeTupleDataDef arity | arity <- [2..32] ] + -- We don't have a way of avoiding the upper bound. + ++ [ makeTupleDataDef arity + | arity <- [2..32] ] -- | Make a tuple data def for the given tuple arity. makeTupleDataDef :: Int -> DataDef Name makeTupleDataDef n - = DataDef + = makeDataDefAlg (NameTyConFlow (TyConFlowTuple n)) - (replicate n kData) + (replicate n (BAnon kData)) (Just [ ( NameDaConFlow (DaConFlowTuple n) , (reverse [tIx kData i | i <- [0..n - 1]]))]) @@ -106,7 +111,7 @@ kindOfPrimName :: Name -> Maybe (Kind Name) kindOfPrimName nn = case nn of - NameKiConFlow KiConFlowRate -> Just sProp + NameKiConFlow _ -> Just sProp NameTyConFlow tc -> Just $ kindTyConFlow tc NamePrimTyCon tc -> Just $ kindPrimTyCon tc _ -> Nothing @@ -123,18 +128,22 @@ typeOfPrimName :: Name -> Maybe (Type Name) typeOfPrimName dc = case dc of - NameOpFlow p -> Just $ typeOpFlow p - NameOpLoop p -> Just $ typeOpLoop p - NameOpStore p -> Just $ typeOpStore p - NameDaConFlow p -> Just $ typeDaConFlow p + NameOpConcrete p -> Just $ typeOpConcrete p + NameOpSeries p -> Just $ typeOpSeries p + NameOpStore p -> Just $ typeOpStore p + NameOpControl p -> Just $ typeOpControl p + NameOpVector p -> Just $ typeOpVector p + NameDaConFlow p -> Just $ typeDaConFlow p - NamePrimCast p -> Just $ typePrimCast p - NamePrimArith p -> Just $ typePrimArith p + NamePrimCast p -> Just $ typePrimCast p + NamePrimArith p -> Just $ typePrimArith p + NamePrimVec p -> Just $ typePrimVec p - NameLitBool _ -> Just $ tBool - NameLitNat _ -> Just $ tNat - NameLitInt _ -> Just $ tInt - NameLitWord _ bits -> Just $ tWord bits + NameLitBool _ -> Just $ tBool + NameLitNat _ -> Just $ tNat + NameLitInt _ -> Just $ tInt + NameLitWord _ bits -> Just $ tWord bits + NameLitFloat _ bits -> Just $ tFloat bits _ -> Nothing diff --git a/DDC/Core/Flow/Exp.hs b/DDC/Core/Flow/Exp.hs --- a/DDC/Core/Flow/Exp.hs +++ b/DDC/Core/Flow/Exp.hs @@ -1,6 +1,6 @@ module DDC.Core.Flow.Exp - ( module DDC.Core.Exp.Simple + ( module DDC.Core.Flow.Exp.Simple.Exp , KindEnvF, TypeEnvF , TypeF , ModuleF @@ -15,8 +15,9 @@ where import DDC.Core.Module import DDC.Core.Flow.Prim -import DDC.Core.Exp.Simple -import DDC.Type.Env (Env) +import DDC.Core.Flow.Exp.Simple.Exp +import DDC.Core.Flow.Exp.Simple.Collect () +import DDC.Type.Env (Env) type KindEnvF = Env Name type TypeEnvF = Env Name @@ -33,3 +34,5 @@ type BoundF = Bound Name type BindF = Bind Name + + diff --git a/DDC/Core/Flow/Exp/Simple/Collect.hs b/DDC/Core/Flow/Exp/Simple/Collect.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Exp/Simple/Collect.hs @@ -0,0 +1,77 @@ +-- | Collecting sets of variables and constructors. +module DDC.Core.Flow.Exp.Simple.Collect + () +where +import DDC.Core.Collect.BindStruct +import DDC.Core.Collect.FreeX +import DDC.Core.Flow.Exp.Simple.Exp + + +-- Exp ------------------------------------------------------------------------ +instance BindStruct (Exp a n) n where + slurpBindTree xx + = case xx of + XAnnot _ x + -> slurpBindTree x + XVar u + -> [BindUse BoundExp u] + + XCon dc + -> case dc of + DaConBound n -> [BindCon BoundExp (UName n) Nothing] + _ -> [] + + XApp x1 x2 -> slurpBindTree x1 ++ slurpBindTree x2 + XLAM b x -> [bindDefT BindLAM [b] [x]] + XLam b x -> [bindDefX BindLam [b] [x]] + + XLet (LLet b x1) x2 + -> slurpBindTree x1 + ++ [bindDefX BindLet [b] [x2]] + + XLet (LRec bxs) x2 + -> [bindDefX BindLetRec + (map fst bxs) + (map snd bxs ++ [x2])] + + XLet (LPrivate bsR mtExtend bs) x2 + -> (case mtExtend of + Nothing -> [] + Just tR -> slurpBindTree tR) + ++ [ BindDef BindLetRegions bsR + [bindDefX BindLetRegionWith bs [x2]] ] + + XCase x alts -> slurpBindTree x ++ concatMap slurpBindTree alts + XCast c x -> slurpBindTree c ++ slurpBindTree x + XType t -> slurpBindTree t + XWitness w -> slurpBindTree w + + +instance BindStruct (Cast a n) n where + slurpBindTree cc + = case cc of + CastWeakenEffect eff -> slurpBindTree eff + CastPurify w -> slurpBindTree w + CastBox -> [] + CastRun -> [] + + +instance BindStruct (Alt a n) n where + slurpBindTree alt + = case alt of + AAlt PDefault x + -> slurpBindTree x + + AAlt (PData _ bs) x + -> [bindDefX BindCasePat bs [x]] + + +instance BindStruct (Witness a n) n where + slurpBindTree ww + = case ww of + WVar u -> [BindUse BoundWit u] + WCon{} -> [] + WApp w1 w2 -> slurpBindTree w1 ++ slurpBindTree w2 + WType t -> slurpBindTree t + WAnnot _ w -> slurpBindTree w + diff --git a/DDC/Core/Flow/Exp/Simple/Compounds.hs b/DDC/Core/Flow/Exp/Simple/Compounds.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Exp/Simple/Compounds.hs @@ -0,0 +1,287 @@ + +-- | Utilities for constructing and destructing compound expressions. +-- +-- For the Simple version of the AST. +module DDC.Core.Flow.Exp.Simple.Compounds + ( module DDC.Type.Exp.Simple.Compounds + + -- * Lambdas + , xLAMs + , xLams + , makeXLamFlags + , takeXLAMs + , takeXLams + , takeXLamFlags + + -- * Applications + , xApps + , takeXApps + , takeXApps1 + , takeXAppsAsList + , takeXConApps + , takeXPrimApps + + -- * Lets + , xLets + , splitXLets + , bindsOfLets + , specBindsOfLets + , valwitBindsOfLets + + -- * Patterns + , bindsOfPat + + -- * Alternatives + , takeCtorNameOfAlt + + -- * Witnesses + , wApp + , wApps + , takeXWitness + , takeWAppsAsList + , takePrimWiConApps + + -- * Types + , takeXType + + -- * Data Constructors + , xUnit, C.dcUnit + , C.takeNameOfDaCon + , C.takeTypeOfDaCon) +where +import DDC.Core.Flow.Exp.Simple.Exp +import DDC.Type.Exp.Simple.Compounds +import qualified DDC.Core.Exp.Annot as C + + +-- Lambdas --------------------------------------------------------------------- +-- | Make some nested type lambdas. +xLAMs :: [Bind n] -> Exp a n -> Exp a n +xLAMs bs x + = foldr XLAM x bs + + +-- | Make some nested value or witness lambdas. +xLams :: [Bind n] -> Exp a n -> Exp a n +xLams bs x + = foldr XLam x bs + + +-- | Split type lambdas from the front of an expression, +-- or `Nothing` if there aren't any. +takeXLAMs :: Exp a n -> Maybe ([Bind n], Exp a n) +takeXLAMs xx + = let go bs (XLAM b x) = go (b:bs) x + go bs x = (reverse bs, x) + in case go [] xx of + ([], _) -> Nothing + (bs, body) -> Just (bs, body) + + +-- | Split nested value or witness lambdas from the front of an expression, +-- or `Nothing` if there aren't any. +takeXLams :: Exp a n -> Maybe ([Bind n], Exp a n) +takeXLams xx + = let go bs (XLam b x) = go (b:bs) x + go bs x = (reverse bs, x) + in case go [] xx of + ([], _) -> Nothing + (bs, body) -> Just (bs, body) + + +-- | Make some nested lambda abstractions, +-- using a flag to indicate whether the lambda is a +-- level-1 (True), or level-0 (False) binder. +makeXLamFlags :: [(Bool, Bind n)] -> Exp a n -> Exp a n +makeXLamFlags fbs x + = foldr (\(f, b) x' + -> if f then XLAM b x' + else XLam b x') + x fbs + + +-- | Split nested lambdas from the front of an expression, +-- with a flag indicating whether the lambda was a level-1 (True), +-- or level-0 (False) binder. +takeXLamFlags :: Exp a n -> Maybe ([(Bool, Bind n)], Exp a n) +takeXLamFlags xx + = let go bs (XLAM b x) = go ((True, b):bs) x + go bs (XLam b x) = go ((False, b):bs) x + go bs x = (reverse bs, x) + in case go [] xx of + ([], _) -> Nothing + (bs, body) -> Just (bs, body) + + +-- Applications --------------------------------------------------------------- +-- | Build sequence of value applications. +xApps :: Exp a n -> [Exp a n] -> Exp a n +xApps t1 ts = foldl XApp t1 ts + + +-- | Flatten an application into the function part and its arguments. +-- +-- Returns `Nothing` if there is no outer application. +takeXApps :: Exp a n -> Maybe (Exp a n, [Exp a n]) +takeXApps xx + = case takeXAppsAsList xx of + (x1 : xsArgs) -> Just (x1, xsArgs) + _ -> Nothing + + +-- | Flatten an application into the function part and its arguments. +-- +-- This is like `takeXApps` above, except we know there is at least one argument. +takeXApps1 :: Exp a n -> Exp a n -> (Exp a n, [Exp a n]) +takeXApps1 x1 x2 + = case takeXApps x1 of + Nothing -> (x1, [x2]) + Just (x11, x12s) -> (x11, x12s ++ [x2]) + + +-- | Flatten an application into the function parts and arguments, if any. +takeXAppsAsList :: Exp a n -> [Exp a n] +takeXAppsAsList xx + = case xx of + XApp x1 x2 -> takeXAppsAsList x1 ++ [x2] + _ -> [xx] + + +-- | Flatten an application of a primop into the variable +-- and its arguments. +-- +-- Returns `Nothing` if the expression isn't a primop application. +takeXPrimApps :: Exp a n -> Maybe (n, [Exp a n]) +takeXPrimApps xx + = case takeXAppsAsList xx of + XVar (UPrim p _) : xs -> Just (p, xs) + _ -> Nothing + +-- | Flatten an application of a data constructor into the constructor +-- and its arguments. +-- +-- Returns `Nothing` if the expression isn't a constructor application. +takeXConApps :: Exp a n -> Maybe (DaCon n (Type n), [Exp a n]) +takeXConApps xx + = case takeXAppsAsList xx of + XCon dc : xs -> Just (dc, xs) + _ -> Nothing + + +-- Lets ----------------------------------------------------------------------- +-- | Wrap some let-bindings around an expression. +xLets :: [Lets a n] -> Exp a n -> Exp a n +xLets lts x + = foldr XLet x lts + + +-- | Split let-bindings from the front of an expression, if any. +splitXLets :: Exp a n -> ([Lets a n], Exp a n) +splitXLets xx + = case xx of + XLet lts x + -> let (lts', x') = splitXLets x + in (lts : lts', x') + + _ -> ([], xx) + + +-- | Take the binds of a `Lets`. +-- +-- The level-1 and level-0 binders are returned separately. +bindsOfLets :: Lets a n -> ([Bind n], [Bind n]) +bindsOfLets ll + = case ll of + LLet b _ -> ([], [b]) + LRec bxs -> ([], map fst bxs) + LPrivate bs _ bbs -> (bs, bbs) + + +-- | Like `bindsOfLets` but only take the spec (level-1) binders. +specBindsOfLets :: Lets a n -> [Bind n] +specBindsOfLets ll + = case ll of + LLet _ _ -> [] + LRec _ -> [] + LPrivate bs _ _ -> bs + + +-- | Like `bindsOfLets` but only take the value and witness (level-0) binders. +valwitBindsOfLets :: Lets a n -> [Bind n] +valwitBindsOfLets ll + = case ll of + LLet b _ -> [b] + LRec bxs -> map fst bxs + LPrivate _ _ bs -> bs + + +-- Alternatives --------------------------------------------------------------- +-- | Take the constructor name of an alternative, if there is one. +takeCtorNameOfAlt :: Alt a n -> Maybe n +takeCtorNameOfAlt aa + = case aa of + AAlt (PData dc _) _ -> C.takeNameOfDaCon dc + _ -> Nothing + + +-- Patterns ------------------------------------------------------------------- +-- | Take the binds of a `Pat`. +bindsOfPat :: Pat n -> [Bind n] +bindsOfPat pp + = case pp of + PDefault -> [] + PData _ bs -> bs + + +-- Witnesses ------------------------------------------------------------------ +-- | Construct a witness application +wApp :: Witness a n -> Witness a n -> Witness a n +wApp = WApp + + +-- | Construct a sequence of witness applications +wApps :: Witness a n -> [Witness a n] -> Witness a n +wApps = foldl wApp + + +-- | Take the witness from an `XWitness` argument, if any. +takeXWitness :: Exp a n -> Maybe (Witness a n) +takeXWitness xx + = case xx of + XWitness t -> Just t + _ -> Nothing + + +-- | Flatten an application into the function parts and arguments, if any. +takeWAppsAsList :: Witness a n -> [Witness a n] +takeWAppsAsList ww + = case ww of + WApp w1 w2 -> takeWAppsAsList w1 ++ [w2] + _ -> [ww] + + +-- | Flatten an application of a witness into the witness constructor +-- name and its arguments. +-- +-- Returns nothing if there is no witness constructor in head position. +takePrimWiConApps :: Witness a n -> Maybe (n, [Witness a n]) +takePrimWiConApps ww + = case takeWAppsAsList ww of + WCon wc : args | WiConBound (UPrim n _) _ <- wc + -> Just (n, args) + _ -> Nothing + + +-- Types ---------------------------------------------------------------------- +-- | Take the type from an `XType` argument, if any. +takeXType :: Exp a n -> Maybe (Type n) +takeXType xx + = case xx of + XType t -> Just t + _ -> Nothing + + +-- Units ----------------------------------------------------------------------- +-- | Construct a value of unit type. +xUnit :: Exp a n +xUnit = XCon C.dcUnit diff --git a/DDC/Core/Flow/Exp/Simple/Exp.hs b/DDC/Core/Flow/Exp/Simple/Exp.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Exp/Simple/Exp.hs @@ -0,0 +1,196 @@ + +-- | Core language AST with a separate node to hold annotations. +-- +-- This version of the AST is used when generating code where most or all +-- of the annotations would be empty. General purpose transformations should +-- deal with the fully annotated version of the AST instead. +-- +module DDC.Core.Flow.Exp.Simple.Exp + ( module DDC.Type.Exp + + -- * Expressions + , Exp (..) + , Cast (..) + , Lets (..) + , Alt (..) + , Pat (..) + + -- * Witnesses + , Witness (..) + + -- * Data Constructors + , DaCon (..) + + -- * Witness Constructors + , WiCon (..)) +where +import DDC.Core.Exp (WiCon (..)) +import DDC.Core.Exp (DaCon (..)) +import DDC.Type.Exp +import DDC.Type.Sum () +import Control.DeepSeq + + +-- Values --------------------------------------------------------------------- +-- | Well-typed expressions have types of kind `Data`. +data Exp a n + -- | Annotation. + = XAnnot a (Exp a n) + + -- | Value variable or primitive operation. + | XVar !(Bound n) + + -- | Data constructor or literal. + | XCon !(DaCon n (Type n)) + + -- | Type abstraction (level-1). + | XLAM !(Bind n) !(Exp a n) + + -- | Value and Witness abstraction (level-0). + | XLam !(Bind n) !(Exp a n) + + -- | Application. + | XApp !(Exp a n) !(Exp a n) + + -- | Possibly recursive bindings. + | XLet !(Lets a n) !(Exp a n) + + -- | Case branching. + | XCase !(Exp a n) ![Alt a n] + + -- | Type cast. + | XCast !(Cast a n) !(Exp a n) + + -- | Type can appear as the argument of an application. + | XType !(Type n) + + -- | Witness can appear as the argument of an application. + | XWitness !(Witness a n) + deriving (Show, Eq) + + +-- | Possibly recursive bindings. +data Lets a n + -- | Non-recursive expression binding. + = LLet !(Bind n) !(Exp a n) + + -- | Recursive binding of lambda abstractions. + | LRec ![(Bind n, Exp a n)] + + -- | Bind a local region variable, + -- and witnesses to its properties. + | LPrivate ![Bind n] !(Maybe (Type n)) ![Bind n] + deriving (Show, Eq) + + +-- | Case alternatives. +data Alt a n + = AAlt !(Pat n) !(Exp a n) + deriving (Show, Eq) + + +-- | Pattern matching. +data Pat n + -- | The default pattern always succeeds. + = PDefault + + -- | Match a data constructor and bind its arguments. + | PData !(DaCon n (Type n)) ![Bind n] + deriving (Show, Eq) + + +-- | When a witness exists in the program it guarantees that a +-- certain property of the program is true. +data Witness a n + = WAnnot a (Witness a n) + + -- | Witness variable. + | WVar !(Bound n) + + -- | Witness constructor. + | WCon !(WiCon n) + + -- | Witness application. + | WApp !(Witness a n) !(Witness a n) + + -- | Type can appear as the argument of an application. + | WType !(Type n) + deriving (Show, Eq) + + +-- | Type casts. +data Cast a n + -- | Weaken the effect of an expression. + -- The given effect is added to the effect + -- of the body. + = CastWeakenEffect !(Effect n) + + -- | Purify the effect (action) of an expression. + | CastPurify !(Witness a n) + + -- | Box up a computation, + -- capturing its effects in the S computation type. + | CastBox + + -- | Run a computation, + -- releasing its effects into the environment. + | CastRun + deriving (Show, Eq) + + +-- NFData --------------------------------------------------------------------- +instance (NFData a, NFData n) => NFData (Exp a n) where + rnf xx + = case xx of + XAnnot a x -> rnf a `seq` rnf x + XVar u -> rnf u + XCon dc -> rnf dc + XLAM b x -> rnf b `seq` rnf x + XLam b x -> rnf b `seq` rnf x + XApp x1 x2 -> rnf x1 `seq` rnf x2 + XLet lts x -> rnf lts `seq` rnf x + XCase x alts -> rnf x `seq` rnf alts + XCast c x -> rnf c `seq` rnf x + XType t -> rnf t + XWitness w -> rnf w + + +instance (NFData a, NFData n) => NFData (Cast a n) where + rnf cc + = case cc of + CastWeakenEffect e -> rnf e + CastPurify w -> rnf w + CastBox -> () + CastRun -> () + + +instance (NFData a, NFData n) => NFData (Lets a n) where + rnf lts + = case lts of + LLet b x -> rnf b `seq` rnf x + LRec bxs -> rnf bxs + LPrivate bs1 t2 bs3 -> rnf bs1 `seq` rnf t2 `seq` rnf bs3 + + +instance (NFData a, NFData n) => NFData (Alt a n) where + rnf aa + = case aa of + AAlt w x -> rnf w `seq` rnf x + + +instance NFData n => NFData (Pat n) where + rnf pp + = case pp of + PDefault -> () + PData dc bs -> rnf dc `seq` rnf bs + + +instance (NFData a, NFData n) => NFData (Witness a n) where + rnf ww + = case ww of + WAnnot a w -> rnf a `seq` rnf w + WVar u -> rnf u + WCon c -> rnf c + WApp w1 w2 -> rnf w1 `seq` rnf w2 + WType t -> rnf t + diff --git a/DDC/Core/Flow/Lower.hs b/DDC/Core/Flow/Lower.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Lower.hs @@ -0,0 +1,367 @@ + + +module DDC.Core.Flow.Lower + ( Config (..) + , defaultConfigScalar + , defaultConfigKernel + , defaultConfigVector + , Method (..) + , Lifting (..) + , lowerModule) +where +import DDC.Core.Transform.TransformUpX () +import DDC.Core.Flow.Transform.Slurp +import DDC.Core.Flow.Transform.Schedule +import DDC.Core.Flow.Transform.Schedule.Base +import DDC.Core.Flow.Transform.Extract +import DDC.Core.Flow.Transform.TransformUpX +import DDC.Core.Flow.Transform.Annotate +import DDC.Core.Flow.Transform.Deannotate +import DDC.Core.Flow.Process +import DDC.Core.Flow.Procedure +import DDC.Core.Flow.Compounds +import DDC.Core.Flow.Profile +import DDC.Core.Flow.Prim +import DDC.Core.Flow.Exp +import DDC.Core.Module + + +import qualified DDC.Core.Simplifier as C +import qualified DDC.Core.Simplifier.Recipe as C +import qualified DDC.Core.Transform.Namify as C +import qualified DDC.Core.Transform.Snip as Snip +import qualified DDC.Type.Env as Env +import qualified Control.Monad.State.Strict as S +import qualified Data.Monoid as M +import Control.Monad + + +-- | Configuration for the lower transform. +data Config + = Config + { configMethod :: Method } + deriving (Eq, Show) + + +-- | What lowering method to use. +data Method + -- | Produce sequential scalar code with nested loops. + = MethodScalar + + -- | Produce vector kernel code that only processes an even multiple + -- of the vector width. + | MethodKernel + { methodLifting :: Lifting } + + -- | Try to produce sequential vector code, + -- falling back to scalar code if this is not possible. + | MethodVector + { methodLifting :: Lifting } + deriving (Eq, Show) + + +-- | Config for producing code with just scalar operations. +defaultConfigScalar :: Config +defaultConfigScalar + = Config + { configMethod = MethodScalar } + + +-- | Config for producing code with vector operations, +-- where the loops just handle a size of data which is an even multiple +-- of the vector width. +defaultConfigKernel :: Config +defaultConfigKernel + = Config + { configMethod = MethodKernel (Lifting 8)} + + +-- | Config for producing code with vector operations, +-- where the loops handle arbitrary data sizes, of any number of elements. +defaultConfigVector :: Config +defaultConfigVector + = Config + { configMethod = MethodVector (Lifting 8)} + + +-- Lower ---------------------------------------------------------------------- +-- | Take a module that contains some well formed series processes defined +-- at top-level, and lower them into procedures. +lowerModule :: Config -> ModuleF -> Either Error ModuleF +lowerModule config mm + = case slurpProcesses mm of + -- Can't slurp a process definition from one of the top level series + -- processes. + Left err + -> Left (ErrorSlurpError err) + + -- We've got a process definition for all of then. + Right procs + -> do + -- Find names of all process bindings + let procname (Left p) = [processName p] + procname (Right _) = [] + + procnames = concatMap procname procs + + -- Schedule the processeses into procedures. + lets <- mapM (lowerEither config procnames) procs + + -- Wrap all the procedures into a new module. + let mm_lowered = mm + { moduleBody = annotate () + $ XLet (LRec lets) xUnit } + + -- Clean up extracted code + let mm_clean = cleanModule mm_lowered + return mm_clean + + +-- | Look at slurped result, and if it's a process lower it, otherwise remove any runProcess# inside expressions +lowerEither :: Config -> [Name] -> (Either Process (Bind Name, Exp () Name)) -> Either Error (BindF, ExpF) +lowerEither config _ (Left process) + = lowerProcess config process + +lowerEither _config _procnames (Right (b,xx)) + = let xx' = deannotate (const Nothing) + $ transformSimpleUpX' replaceRunProc + $ annotate () xx + in return (b, xx') + where + + -- Replace all calls to runProcess# with runProcessUnit# + replaceRunProc (XVar (UPrim (NameOpSeries OpSeriesRunProcess) _)) + = Just + $ XVar + $ UPrim (NameOpSeries OpSeriesRunProcessUnit) + (typeOpSeries OpSeriesRunProcessUnit) + -- Also replace any Process# types with Units + replaceRunProc (XType t) + = Just + $ XType (replaceProcTy t) + replaceRunProc (XLet (LLet bind x) e) + = Just + $ XLet (LLet (replaceProcTyB bind) x) e + replaceRunProc (XLet (LRec bxs) e) + | (bs,xs) <- unzip bxs + , bs' <- map replaceProcTyB bs + = Just + $ XLet (LRec (zip bs' xs)) e + + replaceRunProc _ + = Nothing + + replaceProcTyB (BName n t) = BName n $ replaceProcTy t + replaceProcTyB (BAnon t) = BAnon $ replaceProcTy t + replaceProcTyB (BNone t) = BNone $ replaceProcTy t + + -- Replace Process# a b with Unit + replaceProcTy tt + = case tt of + TVar{} -> tt + TCon{} -> tt + + TAbs bind tt' + -> TAbs bind (replaceProcTy tt') + + TApp l r + | Just (NameTyConFlow TyConFlowProcess, [_,_]) <- takePrimTyConApps tt + -> tUnit + | otherwise + -> TApp (replaceProcTy l) (replaceProcTy r) + + TForall bind tt' + -> TForall bind (replaceProcTy tt') + + TSum ts + -> TSum ts + + +-- | Lower a single series process into fused code. +lowerProcess :: Config -> Process -> Either Error (BindF, ExpF) +lowerProcess config process + + -- Scalar lowering ------------------------------ + | MethodScalar <- configMethod config + = do + -- Schedule process into scalar code. + proc <- scheduleScalar process + + -- Extract code for the kernel + let (bProc, xProc) = extractProcedure proc + + return (bProc, xProc) + + + -- Vector lowering ----------------------------- + -- To use the vector method, + -- the type of the source function needs to have a quantifier for + -- the rate variable (k), as well as a (RateNat k) witness. + -- + | MethodVector lifting <- configMethod config + , [nRN] <- [ nRN | (flag, BName nRN tRN) <- processParamFlags process + , not flag + , isRateNatType tRN ] + , tK <- processLoopRate process + = do let c = liftingFactor lifting + + -- The RateNat witness + let xRN = XVar (UName nRN) + + let tProc = processProcType process + let _tLoopRate = processLoopRate process + + ----------------------------------------- + -- Create the vector version of the kernel. + -- Vector code processes several elements per loop iteration. + procVec <- scheduleKernel lifting process + let (_, xProcVec) = extractProcedure procVec + + + let bxsDownSeries + = [ ( bS + , ( BName (NameVarMod n "down") + (tSeries tProc (tDown c tK) tE) + , xDown c tProc tK tE (XVar (UIx 0)) xS)) + | (flag, bS@(BName n tS)) <- processParamFlags process + , not flag + , let Just tE = elemTypeOfSeriesType tS + , let Just uS = takeSubstBoundOfBind bS + , let xS = XVar uS + , isSeriesType tS ] + + -- Get a value arg to give to the vector procedure. + let getDownValArg b + | Just (b', _) <- lookup b bxsDownSeries + = liftM XVar $ takeSubstBoundOfBind b' + + | otherwise + = liftM XVar $ takeSubstBoundOfBind b + + let Just xsVecValArgs + = sequence + $ map getDownValArg + $ map snd + $ filter (not.fst) + $ processParamFlags process + + let bRateDown + = BAnon (tRateNat (tDown c tK)) + + let xProcVec' + = XLam bRateDown + $ xLets [LLet b x | (_, (b, x)) <- bxsDownSeries] + $ xApps xProcVec + $ [XType tProc, XType tK] ++ xsVecValArgs + + + ----------------------------------------- + -- Create tail version. + -- Scalar code processes the final elements of the loop. + procTail <- scheduleScalar process + let (bProcTail, xProcTail) = extractProcedure procTail + + -- Window the input series to select the tails. + let bxsTailSeries + = [ ( bS, ( BName (NameVarMod n "tail") (tSeries tProc (tTail c tK) tE) + , xTail c tProc tK tE (XVar (UIx 0)) xS)) + | (flag, bS@(BName n tS)) <- processParamFlags process + , not flag + , let Just tE = elemTypeOfSeriesType tS + , let Just uS = takeSubstBoundOfBind bS + , let xS = XVar uS + , isSeriesType tS ] + + -- Window the output vectors to select the tails. + let bxsTailVector + = [ ( bV, ( BName (NameVarMod n "tail") (tVector tE) + , xTailVector c tK tE (XVar (UIx 0)) xV)) + | (flag, bV@(BName n tV)) <- processParamFlags process + , not flag + , let Just tE = elemTypeOfVectorType tV + , let Just uV = takeSubstBoundOfBind bV + , let xV = XVar uV + , isVectorType tV ] + + -- Get a value arg to give to the scalar procedure. + let getTailValArg b + | Just (b', _) <- lookup b bxsTailSeries + = liftM XVar $ takeSubstBoundOfBind b' + + | Just (b', _) <- lookup b bxsTailVector + = liftM XVar $ takeSubstBoundOfBind b' + + | otherwise + = liftM XVar $ takeSubstBoundOfBind b + + let Just xsTailValArgs + = sequence + $ map getTailValArg (map snd $ filter (not.fst) $ procedureParamFlags procTail) + + let bRateTail + = BAnon (tRateNat (tTail c tK)) + + let xProcTail' + = XLam bRateTail + $ xLets [LLet b x | (_, (b, x)) <- bxsTailSeries] + $ xLets [LLet b x | (_, (b, x)) <- bxsTailVector] + $ xApps xProcTail + $ [XType tProc, XType (tTail c tK)] ++ xsTailValArgs + + ------------------------------------------ + -- Stich the vector and scalar versions together. + let xProc + = makeXLamFlags (processParamFlags process) + xBody + + xBody + = XLet (LLet (BNone tUnit) + (xSplit c tK xRN xProcVec' xProcTail')) + xUnit + + -- Reconstruct a binder for the whole procedure / process. + let bProc + = BName (processName process) + (typeOfBind bProcTail) + + return (bProc, xProc) + + -- Kernel lowering ----------------------------- + | MethodKernel lifting <- configMethod config + = do + -- Schedule process into + proc <- scheduleKernel lifting process + + -- Extract code for the kernel + let (bProc, xProc) = extractProcedure proc + + return (bProc, xProc) + + | otherwise + = error $ "ddc-core-flow.lowerProcess: invalid lowering method" + + + +-- Clean ---------------------------------------------------------------------- +-- | Do some beta-reductions to ensure that arguments to worker functions +-- are inlined, then normalize nested applications. +-- When snipping, leave lambda abstractions in place so the worker functions +-- applied to our loop combinators aren't moved. +cleanModule :: ModuleF -> ModuleF +cleanModule mm + = let + clean + = C.Trans (C.Namify (C.makeNamifier freshT) + (C.makeNamifier freshX)) + M.<> C.Trans C.Forward + M.<> C.beta + M.<> C.Trans (C.Snip (Snip.configZero { Snip.configPreserveLambdas = True })) + M.<> C.Trans C.Flatten + + mm_cleaned + = C.result $ S.evalState + (C.applySimplifier profile Env.empty Env.empty + (C.Fix 4 clean) mm) + 0 + in mm_cleaned + diff --git a/DDC/Core/Flow/Prim.hs b/DDC/Core/Flow/Prim.hs --- a/DDC/Core/Flow/Prim.hs +++ b/DDC/Core/Flow/Prim.hs @@ -18,21 +18,31 @@ , readDaConFlow , typeDaConFlow - -- * Flow operators - , OpFlow (..) - , readOpFlow - , typeOpFlow + -- * Fusable Flow operators + , OpConcrete (..) + , readOpConcrete + , typeOpConcrete - -- * Loop operators - , OpLoop (..) - , readOpLoop - , typeOpLoop + -- * Series operators + , OpSeries (..) + , readOpSeries + , typeOpSeries + -- * Control operators + , OpControl (..) + , readOpControl + , typeOpControl + -- * Store operators , OpStore (..) , readOpStore , typeOpStore + -- * Store operators + , OpVector (..) + , readOpVector + , typeOpVector + -- * Primitive type constructors , PrimTyCon (..) , kindPrimTyCon @@ -41,6 +51,13 @@ , PrimArith (..) , typePrimArith + -- * Primitive vector operators + , PrimVec (..) + , typePrimVec + , multiOfPrimVec + , liftPrimArithToVec + , lowerPrimVecToArith + -- * Casting between primitive types , PrimCast (..) , typePrimCast) @@ -51,20 +68,34 @@ import DDC.Core.Flow.Prim.TyConPrim import DDC.Core.Flow.Prim.DaConFlow import DDC.Core.Flow.Prim.DaConPrim () -import DDC.Core.Flow.Prim.OpFlow -import DDC.Core.Flow.Prim.OpLoop +import DDC.Core.Flow.Prim.OpConcrete +import DDC.Core.Flow.Prim.OpControl +import DDC.Core.Flow.Prim.OpSeries import DDC.Core.Flow.Prim.OpStore +import DDC.Core.Flow.Prim.OpVector import DDC.Core.Flow.Prim.OpPrim -import DDC.Core.Salt.Name +import DDC.Core.Lexer.Tokens (isVarStart) + +import DDC.Core.Salt.Name ( readPrimTyCon - , readPrimCast + , readPrimArith - , readLitPrimNat - , readLitPrimInt - , readLitPrimWordOfBits) - -import DDC.Base.Pretty + + , readPrimVec + , multiOfPrimVec + , liftPrimArithToVec + , lowerPrimVecToArith + + , readPrimCast + , readLitNat + , readLitInt + , readLitWordOfBits + , readLitFloatOfBits) + +import DDC.Data.Name +import DDC.Data.Pretty +import DDC.Data.ListUtils import Control.DeepSeq import Data.Char @@ -79,18 +110,22 @@ NameKiConFlow con -> rnf con NameTyConFlow con -> rnf con NameDaConFlow con -> rnf con - NameOpFlow op -> rnf op - NameOpLoop op -> rnf op + NameOpConcrete op -> rnf op + NameOpControl op -> rnf op + NameOpSeries op -> rnf op NameOpStore op -> rnf op + NameOpVector op -> rnf op - NamePrimTyCon con -> rnf con - NamePrimArith con -> rnf con - NamePrimCast c -> rnf c + NamePrimTyCon op -> rnf op + NamePrimArith op -> rnf op + NamePrimVec op -> rnf op + NamePrimCast op -> rnf op NameLitBool b -> rnf b NameLitNat n -> rnf n NameLitInt i -> rnf i NameLitWord i bits -> rnf i `seq` rnf bits + NameLitFloat r bits -> rnf r `seq` rnf bits instance Pretty Name where @@ -103,63 +138,89 @@ NameKiConFlow con -> ppr con NameTyConFlow con -> ppr con NameDaConFlow con -> ppr con - NameOpFlow op -> ppr op - NameOpLoop op -> ppr op + NameOpConcrete op -> ppr op + NameOpControl op -> ppr op + NameOpSeries op -> ppr op NameOpStore op -> ppr op + NameOpVector op -> ppr op NamePrimTyCon tc -> ppr tc NamePrimArith op -> ppr op + NamePrimVec op -> ppr op NamePrimCast op -> ppr op NameLitBool True -> text "True#" NameLitBool False -> text "False#" - NameLitNat i -> integer i <> text "#" - NameLitInt i -> integer i <> text "i" <> text "#" - NameLitWord i bits -> integer i <> text "w" <> int bits <> text "#" + NameLitNat i -> integer i <> text "#" + NameLitInt i -> integer i <> text "i" <> text "#" + NameLitWord i bits -> integer i <> text "w" <> int bits <> text "#" + NameLitFloat r bits -> double (fromRational r) <> text "f" <> int bits <> text "#" +instance CompoundName Name where + extendName n str + = NameVarMod n str + + splitName nn + = case nn of + NameVarMod n str -> Just (n, str) + _ -> Nothing + + -- | Read the name of a variable, constructor or literal. readName :: String -> Maybe Name readName str -- Flow fragment specific names. - | Just p <- readKiConFlow str = Just $ NameKiConFlow p - | Just p <- readTyConFlow str = Just $ NameTyConFlow p - | Just p <- readDaConFlow str = Just $ NameDaConFlow p - | Just p <- readOpFlow str = Just $ NameOpFlow p - | Just p <- readOpLoop str = Just $ NameOpLoop p - | Just p <- readOpStore str = Just $ NameOpStore p + | Just p <- readKiConFlow str = Just $ NameKiConFlow p + | Just p <- readTyConFlow str = Just $ NameTyConFlow p + | Just p <- readDaConFlow str = Just $ NameDaConFlow p + | Just p <- readOpConcrete str = Just $ NameOpConcrete p + | Just p <- readOpControl str = Just $ NameOpControl p + | Just p <- readOpSeries str = Just $ NameOpSeries p + | Just p <- readOpStore str = Just $ NameOpStore p + | Just p <- readOpVector str = Just $ NameOpVector p -- Primitive names. - | Just p <- readPrimTyCon str = Just $ NamePrimTyCon p - | Just p <- readPrimArith str = Just $ NamePrimArith p - | Just p <- readPrimCast str = Just $ NamePrimCast p + | Just p <- readPrimTyCon str = Just $ NamePrimTyCon p + | Just p <- readPrimArith str = Just $ NamePrimArith p + | Just p <- readPrimVec str = Just $ NamePrimVec p + | Just p <- readPrimCast str = Just $ NamePrimCast p -- Literal Bools | str == "True#" = Just $ NameLitBool True | str == "False#" = Just $ NameLitBool False -- Literal Nat - | Just val <- readLitPrimNat str + | Just str' <- stripSuffix "#" str + , Just val <- readLitNat str' = Just $ NameLitNat val -- Literal Ints - | Just val <- readLitPrimInt str + | Just str' <- stripSuffix "#" str + , Just val <- readLitInt str' = Just $ NameLitInt val -- Literal Words - | Just (val, bits) <- readLitPrimWordOfBits str + | Just str' <- stripSuffix "#" str + , Just (val, bits) <- readLitWordOfBits str' , elem bits [8, 16, 32, 64] = Just $ NameLitWord val bits + -- Literal Floats + | Just str' <- stripSuffix "#" str + , Just (val, bits) <- readLitFloatOfBits str' + , elem bits [32, 64] + = Just $ NameLitFloat (toRational val) bits + -- Variables. | c : _ <- str - , isLower c + , isVarStart c , Just (str1, strMod) <- splitModString str , Just n <- readName str1 = Just $ NameVarMod n strMod | c : _ <- str - , isLower c + , isVarStart c = Just $ NameVar str -- Constructors. diff --git a/DDC/Core/Flow/Prim/Base.hs b/DDC/Core/Flow/Prim/Base.hs --- a/DDC/Core/Flow/Prim/Base.hs +++ b/DDC/Core/Flow/Prim/Base.hs @@ -4,17 +4,21 @@ , KiConFlow (..) , TyConFlow (..) , DaConFlow (..) - , OpFlow (..) - , OpLoop (..) + , OpConcrete (..) + , OpControl (..) + , OpSeries (..) , OpStore (..) + , OpVector (..) , PrimTyCon (..) , PrimArith (..) + , PrimVec (..) , PrimCast (..)) where import Data.Typeable -import DDC.Core.Salt.Name +import DDC.Core.Salt.Name ( PrimTyCon (..) , PrimArith (..) + , PrimVec (..) , PrimCast (..)) @@ -39,16 +43,22 @@ -- | Fragment specific data constructors. | NameDaConFlow DaConFlow - -- | Flow operators. - | NameOpFlow OpFlow + -- | Concrete series operators. + | NameOpConcrete OpConcrete - -- | Loop operators. - | NameOpLoop OpLoop + -- | Control operators. + | NameOpControl OpControl + -- | Series operators. + | NameOpSeries OpSeries + -- | Store operators. | NameOpStore OpStore + -- | Vector operators. + | NameOpVector OpVector + -- Machine primitives ------------------ -- | A primitive type constructor. | NamePrimTyCon PrimTyCon @@ -59,7 +69,10 @@ -- | Primitive casting between numeric types. | NamePrimCast PrimCast + -- | Primitive vector operators. + | NamePrimVec PrimVec + -- Literals ----------------------------- -- | A boolean literal. | NameLitBool Bool @@ -70,14 +83,18 @@ -- | An integer literal. | NameLitInt Integer - -- | A word literal. - | NameLitWord Integer Int + -- | A word literal, with the given number of bits precision. + | NameLitWord Integer Int + + -- | A float literal, with the given number of bits precision. + | NameLitFloat Rational Int deriving (Eq, Ord, Show, Typeable) -- | Fragment specific kind constructors. data KiConFlow = KiConFlowRate + | KiConFlowProc deriving (Eq, Ord, Show) @@ -86,9 +103,15 @@ -- | @TupleN#@ constructor. Tuples. = TyConFlowTuple Int - -- | @Vector#@ constructor. Vectors. + -- | @Vector#@ constructor. Vector is a pair of mutable length and mutable data | TyConFlowVector + -- | @Buffer#@ constructor. Mutable Buffer with no associated length + | TyConFlowBuffer + + -- | @RateVec#@ constructor. Vector is a pair of mutable length and mutable data + | TyConFlowRateVec + -- | @Series#@ constructor. Series types. | TyConFlowSeries @@ -98,14 +121,31 @@ -- | @SelN#@ constructor. Selectors. | TyConFlowSel Int - -- | @Ref#@ constructor. References. + -- | @Ref#@ constructor. References. | TyConFlowRef - -- | @World#@ constructor. State token used when converting to GHC core. + -- | @World#@ constructor. State token used when converting to GHC core. | TyConFlowWorld -- | @RateNat#@ constructor. Naturals witnessing a type-level Rate. | TyConFlowRateNat + + -- | Multiply two @Rate@s together + | TyConFlowRateCross + -- | Add two @Rate@s together + | TyConFlowRateAppend + + -- | @DownN#@ constructor. Rate decimation. + | TyConFlowDown Int + + -- | @TailN#@ constructor. Rate tail after decimation. + | TyConFlowTail Int + + -- | @Process@ constructor. + | TyConFlowProcess + + -- | @Resize p j k@ is a witness that @Process p j@ can be resized to @Process p k@ + | TyConFlowResize deriving (Eq, Ord, Show) @@ -116,49 +156,140 @@ deriving (Eq, Ord, Show) --- | Flow operators. -data OpFlow - -- series conversions. - = OpFlowVectorOfSeries - | OpFlowRateOfSeries - | OpFlowNatOfRateNat +-- | Fusable Flow operators that work on Series. +data OpSeries + -- | Replicate a single element into a series. + = OpSeriesRep - -- selectors - | OpFlowMkSel Int + -- | Segmented replicate. + | OpSeriesReps - -- maps - | OpFlowMap Int + -- | Segmented indices + | OpSeriesIndices - -- replicates - | OpFlowRep - | OpFlowReps + -- | Fill an existing vector from a series. + | OpSeriesFill - -- folds - | OpFlowFold - | OpFlowFoldIndex - | OpFlowFolds + -- | Gather (read) elements from a vector. + | OpSeriesGather - -- unfolds - | OpFlowUnfold - | OpFlowUnfolds + -- | Scatter (write) elements into a vector. + | OpSeriesScatter - -- split/combine - | OpFlowSplit Int - | OpFlowCombine Int + -- | Make a selector. + | OpSeriesMkSel Int - -- packing - | OpFlowPack + -- | Make a segment descriptor. + | OpSeriesMkSegd + + -- | Apply a worker to corresponding elements of some series. + | OpSeriesMap Int + + -- | Pack a series according to a flags vector. + | OpSeriesPack + + -- | Generate a new series with size based on klok/rate + | OpSeriesGenerate + + -- | Reduce a series with an associative operator, + -- updating an existing accumulator. + | OpSeriesReduce + + -- | Segmented fold. + | OpSeriesFolds + + -- | Execute a process + | OpSeriesRunProcess + + -- | Introduce a Proc type, but argument returns unit instead of process + -- Has exact same type as RunProcess except for that, + -- so that they can easily be swapped during lowering + | OpSeriesRunProcessUnit + + -- | Convert vector(s) into manifests, all with same length with runtime check. + | OpSeriesRateVecsOfVectors Int + + -- | Convert manifest into series + | OpSeriesSeriesOfRateVec + + -- | Append two series + | OpSeriesAppend + + -- | Cross a series and a vector + | OpSeriesCross + + + -- | Resize a process + | OpSeriesResizeProc + + -- | Resize a process + | OpSeriesResizeId + + -- | Inject a series into the left side of an append + | OpSeriesResizeAppL + -- | Inject a series into the right side of an append + | OpSeriesResizeAppR + + -- | Map over the contents of an append + | OpSeriesResizeApp + + -- | Move from filtered to filtee + | OpSeriesResizeSel1 + -- | Move from segment data to segment lens + | OpSeriesResizeSegd + -- | Move from (cross a b) to a + | OpSeriesResizeCross + + + -- | Join two series processes. + | OpSeriesJoin deriving (Eq, Ord, Show) --- | Loop operators. -data OpLoop - = OpLoopLoop - | OpLoopLoopN - | OpLoopGuard +-- | Series related operators. +-- These operators work on series after the code has been fused. +-- They do not appear in the source program. +data OpConcrete + -- | Project out a component of a tuple, + -- given the tuple arity and index of the desired component. + = OpConcreteProj Int Int + + -- | Take the rate of a series. + | OpConcreteRateOfSeries + + -- | Take the underlying @Nat@ of a @RateNat@. + | OpConcreteNatOfRateNat + + -- | Take some elements from a series. + | OpConcreteNext Int + + -- | Decimate the rate of a series. + | OpConcreteDown Int + + -- | Take the tail rate of a decimated series. + | OpConcreteTail Int deriving (Eq, Ord, Show) +-- | Control operators. +data OpControl + -- Top level loop, indexed by a rate type. + = OpControlLoop + + -- Top level loop, taking a RateNat. + | OpControlLoopN + + -- Evaluate some function when a flag is true. + | OpControlGuard + + -- Evaluate some function a given number of times. + | OpControlSegment + + -- Used for producing SIMD code. + | OpControlSplit Int + deriving (Eq, Ord, Show) + + -- | Store operators. data OpStore -- Assignables ---------------- @@ -171,7 +302,6 @@ -- | Write to a reference. | OpStoreWrite - -- Vectors -------------------- -- | Allocate a new vector (taking a @Nat@ for the length) | OpStoreNewVector @@ -182,18 +312,47 @@ -- | Allocate a new vector (taking a @RateNat@ for the length) | OpStoreNewVectorN - -- | Read from a vector. - | OpStoreReadVector + -- | Read a packed Vec of values from a Vector buffer. + | OpStoreReadVector Int - -- | Write to a vector. - | OpStoreWriteVector + -- | Write a packed Vec of values to a Vector buffer. + | OpStoreWriteVector Int - -- | Slice after a pack/filter (taking a @Nat@ for new length) - | OpStoreSliceVector + -- | Window a target vector to the tail of some rate. + | OpStoreTailVector Int + -- | Truncate a vector to a smaller length. + | OpStoreTruncVector - -- Streams -------------------- - -- | Take the next element from a series. - | OpStoreNext + -- | Get a vector's data buffer + | OpStoreBufOfVector + + -- | Get a vector's data buffer + | OpStoreBufOfRateVec + deriving (Eq, Ord, Show) + + +-- | Fusable flow operators that work on Vectors. +data OpVector + -- | Apply worker function to @n@ vectors zipped. + = OpVectorMap Int + + -- | Filter a vector according to a predicate. + | OpVectorFilter + + -- | Associative fold. + | OpVectorReduce + + -- | Create a new vector from an index function. + | OpVectorGenerate + + -- | Get a vector's length. + | OpVectorLength + + -- | Gather (read) elements from a vector: + -- + -- > gather v ix = map (v!) ix + -- + | OpVectorGather deriving (Eq, Ord, Show) diff --git a/DDC/Core/Flow/Prim/DaConFlow.hs b/DDC/Core/Flow/Prim/DaConFlow.hs --- a/DDC/Core/Flow/Prim/DaConFlow.hs +++ b/DDC/Core/Flow/Prim/DaConFlow.hs @@ -5,15 +5,17 @@ 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 DDC.Core.Flow.Exp.Simple.Exp +import DDC.Core.Flow.Exp.Simple.Compounds +import DDC.Data.Pretty import Data.List import Data.Char import Control.DeepSeq -instance NFData DaConFlow +instance NFData DaConFlow where + rnf !_ = () + instance Pretty DaConFlow where ppr dc diff --git a/DDC/Core/Flow/Prim/DaConPrim.hs b/DDC/Core/Flow/Prim/DaConPrim.hs --- a/DDC/Core/Flow/Prim/DaConPrim.hs +++ b/DDC/Core/Flow/Prim/DaConPrim.hs @@ -9,18 +9,18 @@ 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 +import DDC.Core.Flow.Exp.Simple.Compounds +import DDC.Core.Flow.Exp.Simple.Exp -- | A literal @Bool#@ xBool :: Bool -> Exp a Name -xBool b = XCon (mkDaConAlg (NameLitBool b) tBool) +xBool b = XCon (dcBool b) -- | A literal @Bool#@ data constructor. -dcBool :: Bool -> DaCon Name -dcBool b = mkDaConAlg (NameLitBool b) tBool +dcBool :: Bool -> DaCon Name (Type Name) +dcBool b = DaConPrim (NameLitBool b) tBool -- | A literal @Nat#@ @@ -29,14 +29,14 @@ -- | A Literal @Nat#@ data constructor. -dcNat :: Integer -> DaCon Name -dcNat i = mkDaConAlg (NameLitInt i) tNat +dcNat :: Integer -> DaCon Name (Type Name) +dcNat i = DaConPrim (NameLitNat i) tNat -- | Data constructor for @Tuple1#@ -dcTuple1 :: DaCon Name -dcTuple1 = mkDaConAlg (NameDaConFlow (DaConFlowTuple 1)) - $ typeDaConFlow (DaConFlowTuple 1) +dcTuple1 :: DaCon Name (Type Name) +dcTuple1 = DaConPrim (NameDaConFlow (DaConFlowTuple 1)) + (typeDaConFlow (DaConFlowTuple 1)) -- | Construct a @Tuple2#@ @@ -50,14 +50,14 @@ -- | Data constructor for @Tuple2#@ -dcTuple2 :: DaCon Name -dcTuple2 = mkDaConAlg (NameDaConFlow (DaConFlowTuple 2)) - $ typeDaConFlow (DaConFlowTuple 2) +dcTuple2 :: DaCon Name (Type Name) +dcTuple2 = DaConPrim (NameDaConFlow (DaConFlowTuple 2)) + (typeDaConFlow (DaConFlowTuple 2)) -- | Data constructor for n-tuples -dcTupleN :: Int -> DaCon Name +dcTupleN :: Int -> DaCon Name (Type Name) dcTupleN n - = mkDaConAlg (NameDaConFlow (DaConFlowTuple n)) - $ typeDaConFlow (DaConFlowTuple n) + = DaConPrim (NameDaConFlow (DaConFlowTuple n)) + (typeDaConFlow (DaConFlowTuple n)) diff --git a/DDC/Core/Flow/Prim/KiConFlow.hs b/DDC/Core/Flow/Prim/KiConFlow.hs --- a/DDC/Core/Flow/Prim/KiConFlow.hs +++ b/DDC/Core/Flow/Prim/KiConFlow.hs @@ -1,22 +1,25 @@ module DDC.Core.Flow.Prim.KiConFlow ( readKiConFlow - , kRate) + , kRate + , kProc ) where import DDC.Core.Flow.Prim.Base -import DDC.Core.Compounds -import DDC.Core.Exp.Simple -import DDC.Base.Pretty +import DDC.Core.Flow.Exp.Simple.Exp +import DDC.Type.Exp.Simple.Compounds +import DDC.Data.Pretty import Control.DeepSeq -instance NFData KiConFlow +instance NFData KiConFlow where + rnf !_ = () instance Pretty KiConFlow where ppr con = case con of KiConFlowRate -> text "Rate" + KiConFlowProc -> text "Proc" -- | Read a kind constructor name. @@ -24,8 +27,11 @@ readKiConFlow str = case str of "Rate" -> Just $ KiConFlowRate + "Proc" -> Just $ KiConFlowProc _ -> Nothing -- Compounds ------------------------------------------------------------------ kRate = TCon (TyConBound (UPrim (NameKiConFlow KiConFlowRate) sProp) sProp) + +kProc = TCon (TyConBound (UPrim (NameKiConFlow KiConFlowProc) sProp) sProp) diff --git a/DDC/Core/Flow/Prim/OpConcrete.hs b/DDC/Core/Flow/Prim/OpConcrete.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Prim/OpConcrete.hs @@ -0,0 +1,194 @@ + +module DDC.Core.Flow.Prim.OpConcrete + ( readOpConcrete + , typeOpConcrete + + -- * Compounds + , xProj + , xRateOfSeries + , xNatOfRateNat + , xNext + , xNextC + + , xDown + , xTail ) +where +import DDC.Core.Flow.Prim.KiConFlow +import DDC.Core.Flow.Prim.TyConFlow +import DDC.Core.Flow.Prim.TyConPrim +import DDC.Core.Flow.Prim.Base +import DDC.Core.Flow.Exp.Simple.Compounds +import DDC.Core.Flow.Exp.Simple.Exp +import DDC.Data.Pretty +import Control.DeepSeq +import Data.List +import Data.Char + + +instance NFData OpConcrete where + rnf !_ = () + + +instance Pretty OpConcrete where + ppr pf + = case pf of + OpConcreteProj arity ix -> text "proj" + <> int arity <> text "_" <> int ix + <> text "#" + + OpConcreteRateOfSeries -> text "rateOfSeries" <> text "#" + OpConcreteNatOfRateNat -> text "natOfRateNat" <> text "#" + + OpConcreteNext 1 -> text "next#" + OpConcreteNext n -> text "next$" <> int n <> text "#" + + OpConcreteDown n -> text "down$" <> int n <> text "#" + OpConcreteTail n -> text "tail$" <> int n <> text "#" + + +-- | Read a series operator name. +readOpConcrete :: String -> Maybe OpConcrete +readOpConcrete str + | Just rest <- stripPrefix "proj" str + , (ds, '_' : rest2) <- span isDigit rest + , not $ null ds + , arity <- read ds + , arity >= 1 + , (ds2, "#") <- span isDigit rest2 + , not $ null ds2 + , ix <- read ds2 + , ix >= 1 + , ix <= arity + = Just $ OpConcreteProj arity ix + + + | Just rest <- stripPrefix "next$" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + , n >= 1 + = Just $ OpConcreteNext n + + | Just rest <- stripPrefix "down$" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + , n >= 1 + = Just $ OpConcreteDown n + + | Just rest <- stripPrefix "tail$" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + , n >= 1 + = Just $ OpConcreteTail n + + | otherwise + = case str of + "rateOfSeries#" -> Just $ OpConcreteRateOfSeries + "natOfRateNat#" -> Just $ OpConcreteNatOfRateNat + "next#" -> Just $ OpConcreteNext 1 + _ -> Nothing + + +-- | Yield the type of a series operator. +typeOpConcrete :: OpConcrete -> Type Name +typeOpConcrete op + = case op of + -- Tuple projections -------------------- + OpConcreteProj a ix + -> tForalls (replicate a kData) + $ \_ -> tFun (tTupleN [TVar (UIx i) | i <- reverse [0..a-1]]) + (TVar (UIx (a - ix))) + + + -- rateOfSeries# :: [p : Proc]. [k : Rate]. [a : Data] + -- . Series p k a -> RateNat k + OpConcreteRateOfSeries + -> tForalls [kProc, kRate, kData] $ \[tP, tKR, tA] + -> tSeries tP tKR tA `tFun` tRateNat tKR + + -- natOfRateNat# :: [k : Rate]. RateNat k -> Nat# + OpConcreteNatOfRateNat + -> tForall kRate $ \tK + -> tRateNat tK `tFun` tNat + + -- next# :: [a : Data]. [k : Rate]. Series# k a -> Nat# -> a + OpConcreteNext 1 + -> tForalls [kData, kProc, kRate] + $ \[tA, tP, tK] -> tSeries tP tK tA `tFun` tNat `tFun` tA + + -- next$N# :: [a : Data]. [k : Rate] + -- . Series# (DownN# k) a -> Nat# -> VecN# a + OpConcreteNext n + -> tForalls [kData, kProc, kRate] + $ \[tA, tP, tK] -> tSeries tP (tDown n tK) tA `tFun` tNat `tFun` tVec n tA + + -- down$N# :: [k : Rate]. [a : Data]. + -- . RateNat (DownN# k) -> Series# k a -> Series# (DownN# k) a + OpConcreteDown n + -> tForalls [kProc, kRate, kData] + $ \[tP, tK, tA] -> tRateNat (tDown n tK) + `tFun` tSeries tP tK tA `tFun` tSeries tP (tDown n tK) tA + + -- tail$N# :: [k : Rate]. [a : Data]. + -- . RateNat (TailN# k) -> Series# k a -> Series# (TailN# k) a + OpConcreteTail n + -> tForalls [kProc, kRate, kData] + $ \[tP, tK, tA] -> tRateNat (tTail n tK) + `tFun` tSeries tP tK tA `tFun` tSeries tP (tTail n tK) tA + + + +-- Compounds ------------------------------------------------------------------ +type TypeF = Type Name +type ExpF = Exp () Name + +xProj :: [Type Name] -> Int -> Exp () Name -> Exp () Name +xProj ts ix x + = xApps (xVarOpConcrete (OpConcreteProj (length ts) ix)) + ([XType t | t <- ts] ++ [x]) + + +xRateOfSeries :: TypeF -> TypeF -> TypeF -> ExpF -> ExpF +xRateOfSeries tP tK tA xS + = xApps (xVarOpConcrete OpConcreteRateOfSeries) + [XType tP, XType tK, XType tA, xS] + + +xNatOfRateNat :: TypeF -> ExpF -> ExpF +xNatOfRateNat tK xR + = xApps (xVarOpConcrete OpConcreteNatOfRateNat) + [XType tK, xR] + + +xNext :: TypeF -> TypeF -> TypeF -> ExpF -> ExpF -> ExpF +xNext tProc tRate tElem xStream xIndex + = xApps (xVarOpConcrete (OpConcreteNext 1)) + [XType tElem, XType tProc, XType tRate, xStream, xIndex] + + +xNextC :: Int -> TypeF -> TypeF -> TypeF -> ExpF -> ExpF -> ExpF +xNextC c tProc tRate tElem xStream xIndex + = xApps (xVarOpConcrete (OpConcreteNext c)) + [XType tElem, XType tProc, XType tRate, xStream, xIndex] + + +xDown :: Int -> TypeF -> TypeF -> TypeF -> ExpF -> ExpF -> ExpF +xDown n tP tK tE xRN xS + = xApps (xVarOpConcrete (OpConcreteDown n)) + [XType tP, XType tK, XType tE, xRN, xS] + + +xTail :: Int -> TypeF -> TypeF -> TypeF -> ExpF -> ExpF -> ExpF +xTail n tP tK tE xRN xS + = xApps (xVarOpConcrete (OpConcreteTail n)) + [XType tP, XType tK, XType tE, xRN, xS] + + + +-- Utils ----------------------------------------------------------------------- +xVarOpConcrete :: OpConcrete -> Exp () Name +xVarOpConcrete op + = XVar (UPrim (NameOpConcrete op) (typeOpConcrete op)) + diff --git a/DDC/Core/Flow/Prim/OpControl.hs b/DDC/Core/Flow/Prim/OpControl.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Prim/OpControl.hs @@ -0,0 +1,131 @@ + +-- | Control constructs used in lowered code. +module DDC.Core.Flow.Prim.OpControl + ( readOpControl + , typeOpControl + , xLoopN + , xGuard + , xSegment + , xSplit) +where +import DDC.Core.Flow.Prim.KiConFlow +import DDC.Core.Flow.Prim.TyConPrim +import DDC.Core.Flow.Prim.TyConFlow +import DDC.Core.Flow.Prim.Base +import DDC.Core.Flow.Exp.Simple.Compounds +import DDC.Core.Flow.Exp.Simple.Exp +import DDC.Data.Pretty +import Control.DeepSeq +import Data.Char +import Data.List + + +instance NFData OpControl where + rnf !_ = () + + +instance Pretty OpControl where + ppr fo + = case fo of + OpControlLoop -> text "loop#" + OpControlLoopN -> text "loopn#" + OpControlGuard -> text "guard#" + OpControlSegment -> text "segment#" + OpControlSplit n -> text "split$" <> int n <> text "#" + + +-- | Read a control operator name. +readOpControl :: String -> Maybe OpControl +readOpControl str + | Just rest <- stripPrefix "split$" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , arity <- read ds + = Just $ OpControlSplit arity + + | otherwise + = case str of + "loop#" -> Just $ OpControlLoop + "loopn#" -> Just $ OpControlLoopN + "guard#" -> Just $ OpControlGuard + "segment#" -> Just $ OpControlSegment + _ -> Nothing + + +-- Types ---------------------------------------------------------------------- +-- | Yield the type of a control operator. +typeOpControl :: OpControl -> Type Name +typeOpControl op + = case op of + -- loop# :: [k : Rate]. (Nat# -> Unit) -> Unit + OpControlLoop + -> tForall kRate + $ \_ -> (tNat `tFun` tUnit) `tFun` tUnit + + -- loopn# :: [k : Rate]. RateNat# k -> (Nat# -> Unit) -> Unit + OpControlLoopN + -> tForall kRate + $ \kR -> tRateNat kR `tFun` (tNat `tFun` tUnit) `tFun` tUnit + + -- guard# :: Ref# Nat# -> Bool# -> (Nat# -> Unit) -> Unit + OpControlGuard + -> tBool + `tFun` (tUnit `tFun` tUnit) + `tFun` tUnit + + -- segment# :: Ref Nat# -> Nat# -> (Nat# -> Nat# -> Unit) -> Unit + -- In the worker the first parameter is the index of the current + -- element in the segment, and the second is the index into the + -- overall series. + OpControlSegment + -> tNat + `tFun` (tNat `tFun` tUnit) + `tFun` tUnit + + -- split# :: [k : Rate]. RateNat# k + -- -> (RateNat# (Down8# k) -> Unit) + -- -> (RateNat# (Tail8# k) -> Unit) + -- -> Unit + OpControlSplit n + -> tForall kRate + $ \tK -> tRateNat tK + `tFun` (tRateNat (tDown n tK) `tFun` tUnit) + `tFun` (tRateNat (tTail n tK) `tFun` tUnit) + `tFun` tUnit + + +-- Compounds ------------------------------------------------------------------ +type TypeF = Type Name +type ExpF = Exp () Name + + +xLoopN :: TypeF -> ExpF -> ExpF -> ExpF +xLoopN tR xRN xF + = xApps (xVarOpControl OpControlLoopN) + [XType tR, xRN, xF] + + +xGuard :: ExpF -> ExpF -> ExpF +xGuard xFlag xFun + = xApps (xVarOpControl OpControlGuard) + [xFlag, xFun] + + +xSegment :: ExpF -> ExpF -> ExpF +xSegment xIters xFun + = xApps (xVarOpControl OpControlSegment) + [xIters, xFun] + + +xSplit :: Int -> TypeF -> ExpF + -> ExpF -> ExpF -> ExpF +xSplit n tK xRN xDownFn xTailFn + = xApps (xVarOpControl $ OpControlSplit n) + [ XType tK, xRN, xDownFn, xTailFn ] + + +-- Utils ----------------------------------------------------------------------- +xVarOpControl :: OpControl -> ExpF +xVarOpControl op + = XVar (UPrim (NameOpControl op) (typeOpControl op)) + diff --git a/DDC/Core/Flow/Prim/OpFlow.hs b/DDC/Core/Flow/Prim/OpFlow.hs deleted file mode 100644 --- a/DDC/Core/Flow/Prim/OpFlow.hs +++ /dev/null @@ -1,252 +0,0 @@ - -module DDC.Core.Flow.Prim.OpFlow - ( readOpFlow - , typeOpFlow - , xRateOfSeries - , xNatOfRateNat) -where -import DDC.Core.Flow.Prim.KiConFlow -import DDC.Core.Flow.Prim.TyConFlow -import DDC.Core.Flow.Prim.TyConPrim -import DDC.Core.Flow.Prim.Base -import DDC.Core.Transform.LiftT -import DDC.Core.Compounds.Simple -import DDC.Core.Exp.Simple -import DDC.Base.Pretty -import Control.DeepSeq -import Data.List -import Data.Char - - -instance NFData OpFlow - - -instance Pretty OpFlow where - ppr pf - = case pf of - OpFlowVectorOfSeries -> text "vectorOfSeries" <> text "#" - OpFlowRateOfSeries -> text "rateOfSeries" <> text "#" - OpFlowNatOfRateNat -> text "natOfRateNat" <> text "#" - - OpFlowMkSel 1 -> text "mkSel" <> text "#" - OpFlowMkSel n -> text "mkSel" <> int n <> text "#" - - OpFlowMap 1 -> text "map" <> text "#" - OpFlowMap i -> text "map" <> int i <> text "#" - - OpFlowRep -> text "rep" <> text "#" - OpFlowReps -> text "reps" <> text "#" - - OpFlowFold -> text "fold" <> text "#" - OpFlowFoldIndex -> text "foldIndex" <> text "#" - OpFlowFolds -> text "folds" <> text "#" - - OpFlowUnfold -> text "unfold" <> text "#" - OpFlowUnfolds -> text "unfolds" <> text "#" - - OpFlowSplit i -> text "split" <> int i <> text "#" - OpFlowCombine i -> text "combine" <> int i <> text "#" - - OpFlowPack -> text "pack" <> text "#" - - --- | Read a data flow operator name. -readOpFlow :: String -> Maybe OpFlow -readOpFlow str - | Just rest <- stripPrefix "mkSel" str - , (ds, "#") <- span isDigit rest - , not $ null ds - , arity <- read ds - , arity == 1 - = Just $ OpFlowMkSel arity - - | Just rest <- stripPrefix "map" str - , (ds, "#") <- span isDigit rest - , not $ null ds - , arity <- read ds - = Just $ OpFlowMap arity - - | Just rest <- stripPrefix "split" str - , (ds, "#") <- span isDigit rest - , not $ null ds - , arity <- read ds - = Just $ OpFlowSplit arity - - | Just rest <- stripPrefix "combine" str - , (ds, "#") <- span isDigit rest - , not $ null ds - , arity <- read ds - = Just $ OpFlowCombine arity - - | otherwise - = case str of - "vectorOfSeries#" -> Just $ OpFlowVectorOfSeries - "rateOfSeries#" -> Just $ OpFlowRateOfSeries - "natOfRateNat#" -> Just $ OpFlowNatOfRateNat - "mkSel#" -> Just $ OpFlowMkSel 1 - "map#" -> Just $ OpFlowMap 1 - "rep#" -> Just $ OpFlowRep - "reps#" -> Just $ OpFlowReps - "fold#" -> Just $ OpFlowFold - "foldIndex#" -> Just $ OpFlowFoldIndex - "folds#" -> Just $ OpFlowFolds - "unfold#" -> Just $ OpFlowUnfold - "unfolds#" -> Just $ OpFlowUnfolds - "pack#" -> Just $ OpFlowPack - _ -> Nothing - - --- Types ----------------------------------------------------------------------- --- | Yield the type of a data flow operator, --- or `error` if there isn't one. -typeOpFlow :: OpFlow -> Type Name -typeOpFlow op - = case takeTypeOpFlow op of - Just t -> t - Nothing -> error $ "ddc-core-flow.typeOpFlow: invalid op " ++ show op - - --- | Yield the type of a data flow operator. -takeTypeOpFlow :: OpFlow -> Maybe (Type Name) -takeTypeOpFlow op - = case op of - -- Series Conversions ------------------- - -- vectorOfSeries# :: [k : Rate]. [a : Data] - -- . Series k a -> Vector a - OpFlowVectorOfSeries - -> Just $ tForalls [kRate, kData] $ \[tK, tA] - -> tSeries tK tA `tFun` tVector tA - - -- rateOfSeries# :: [k : Rate]. [a : Data] - -- . Series k a -> RateNat k - OpFlowRateOfSeries - -> Just $ tForalls [kRate, kData] $ \[tK, tA] - -> tSeries tK tA `tFun` tRateNat tK - - -- natOfRateNat# :: [k : Rate]. RateNat k -> Nat# - OpFlowNatOfRateNat - -> Just $ tForall kRate $ \tK - -> tRateNat tK `tFun` tNat - - - -- Selectors ---------------------------- - -- mkSel1# :: [k1 : Rate]. [a : Data] - -- . Series k1 Bool# - -- -> ([k2 : Rate]. Sel1 k1 k2 -> a) - -- -> a - OpFlowMkSel 1 - -> Just $ tForalls [kRate, kData] $ \[tK1, tA] - -> tSeries tK1 tBool - `tFun` (tForall kRate $ \tK2 - -> tSel1 (liftT 1 tK1) tK2 `tFun` (liftT 1 tA)) - `tFun` tA - - - -- Maps --------------------------------- - -- map :: [k : Rate] [a b : Data] - -- . (a -> b) -> Series k a -> Series k b - OpFlowMap 1 - -> Just $ tForalls [kRate, kData, kData] $ \[tK, tA, tB] - -> (tA `tFun` tB) - `tFun` tSeries tK tA - `tFun` tSeries tK tB - - -- mapN :: [k : Rate] [a0..aN : Data] - -- . (a0 -> .. aN) -> Series k a0 -> .. Series k aN - OpFlowMap n - | n >= 2 - , Just tWork <- tFunOfList - [ TVar (UIx i) - | i <- reverse [0..n] ] - - , Just tBody <- tFunOfList - (tWork : [tSeries (TVar (UIx (n + 1))) (TVar (UIx i)) - | i <- reverse [0..n] ]) - - -> Just $ foldr TForall tBody - [ BAnon k | k <- kRate : replicate (n + 1) kData ] - - - -- Replicates ------------------------- - -- rep :: [a : Data] [k : Rate] - -- . a -> Series k a - OpFlowRep - -> Just $ tForalls [kData, kRate] $ \[tA, tR] - -> tA `tFun` tSeries tR tA - - -- reps :: [k1 k2 : Rate]. [a : Data] - -- . Segd k1 k2 - -- -> Series k1 a - -- -> Series k2 a - OpFlowReps - -> Just $ tForalls [kRate, kRate, kData] $ \[tK1, tK2, tA] - -> tSegd tK1 tK2 - `tFun` tSeries tK1 tA - `tFun` tSeries tK2 tA - - - -- Folds -------------------------------- - -- fold :: [k : Rate]. [a b: Data] - -- . (a -> b -> a) -> a -> Series k b -> a - OpFlowFold - -> Just $ tForalls [kRate, kData, kData] $ \[tK, tA, tB] - -> (tA `tFun` tB `tFun` tA) - `tFun` tA - `tFun` tSeries tK tB - `tFun` tA - - -- foldIndex :: [k : Rate]. [a b: Data] - -- . (Int# -> a -> b -> a) -> a -> Series k b -> a - OpFlowFoldIndex - -> Just $ tForalls [kRate, kData, kData] $ \[tK, tA, tB] - -> (tInt `tFun` tA `tFun` tB `tFun` tA) - `tFun` tA - `tFun` tSeries tK tB - `tFun` tA - - -- folds :: [k1 k2 : Rate]. [a b: Data] - -- . Segd k1 k2 - -- -> (a -> b -> a) -- fold operator - -- -> Series k1 a -- start values - -- -> Series k2 b -- source elements - -- -> Series k1 a -- result values - OpFlowFolds - -> Just $ tForalls [kRate, kRate, kData, kData] $ \[tK1, tK2, tA, tB] - -> tSegd tK1 tK2 - `tFun` (tInt `tFun` tA `tFun` tB `tFun` tA) - `tFun` tSeries tK1 tA - `tFun` tSeries tK2 tB - `tFun` tSeries tK1 tA - - - -- Packs -------------------------------- - -- pack :: [k1 k2 : Rate]. [a : Data] - -- . Sel2 k1 k2 - -- -> Series k1 a -> Series k2 a - OpFlowPack - -> Just $ tForalls [kRate, kRate, kData] $ \[tK1, tK2, tA] - -> tSel1 tK1 tK2 - `tFun` tSeries tK1 tA - `tFun` tSeries tK2 tA - - _ -> Nothing - - --- Compounds ------------------------------------------------------------------ -xRateOfSeries :: Type Name -> Type Name -> Exp () Name -> Exp () Name -xRateOfSeries tK tA xS - = xApps (xVarOpFlow OpFlowRateOfSeries) - [XType tK, XType tA, xS] - - -xNatOfRateNat :: Type Name -> Exp () Name -> Exp () Name -xNatOfRateNat tK xR - = xApps (xVarOpFlow OpFlowNatOfRateNat) - [XType tK, xR] - - --- Utils ----------------------------------------------------------------------- -xVarOpFlow :: OpFlow -> Exp () Name -xVarOpFlow op - = XVar (UPrim (NameOpFlow op) (typeOpFlow op)) - diff --git a/DDC/Core/Flow/Prim/OpLoop.hs b/DDC/Core/Flow/Prim/OpLoop.hs deleted file mode 100644 --- a/DDC/Core/Flow/Prim/OpLoop.hs +++ /dev/null @@ -1,84 +0,0 @@ - --- | Loop related names. -module DDC.Core.Flow.Prim.OpLoop - ( readOpLoop - , typeOpLoop - , xLoopLoopN - , xLoopGuard) -where -import DDC.Core.Flow.Prim.KiConFlow -import DDC.Core.Flow.Prim.TyConPrim -import DDC.Core.Flow.Prim.TyConFlow -import DDC.Core.Flow.Prim.Base -import DDC.Core.Compounds.Simple -import DDC.Core.Exp.Simple -import DDC.Base.Pretty -import Control.DeepSeq - - -instance NFData OpLoop - - -instance Pretty OpLoop where - ppr fo - = case fo of - OpLoopLoop -> text "loop#" - OpLoopLoopN -> text "loopn#" - - OpLoopGuard -> text "guard#" - - --- | Read a loop operator name. -readOpLoop :: String -> Maybe OpLoop -readOpLoop str - = case str of - "loop#" -> Just $ OpLoopLoop - "loopn#" -> Just $ OpLoopLoopN - "guard#" -> Just $ OpLoopGuard - _ -> Nothing - - --- Types ---------------------------------------------------------------------- --- | Yield the type of a loop operator. -typeOpLoop :: OpLoop -> Type Name -typeOpLoop op - = case op of - -- loop# :: [k : Rate]. (Nat# -> Unit) -> Unit - OpLoopLoop - -> tForall kRate - $ \_ -> (tNat `tFun` tUnit) `tFun` tUnit - - -- loopn# :: [k : Rate]. RateNat k -> (Nat# -> Unit) -> Unit - OpLoopLoopN - -> tForall kRate - $ \kR -> tRateNat kR `tFun` (tNat `tFun` tUnit) `tFun` tUnit - - -- guard# :: Ref# Nat# -> Bool# - -- -> (Nat# -> Unit) -> Unit - OpLoopGuard - -> tRef tNat - `tFun` tBool - `tFun` (tNat `tFun` tUnit) - `tFun` tUnit - - --- Compounds ------------------------------------------------------------------ -xLoopLoopN :: Type Name -> Exp () Name -> Exp () Name -> Exp () Name -xLoopLoopN tR xRN xF - = xApps (xVarOpLoop OpLoopLoopN) [XType tR, xRN, xF] - - -xLoopGuard - :: Exp () Name -- ^ Reference to guard counter. - -> Exp () Name -- ^ Boolean flag to test. - -> Exp () Name -- ^ Body of guard. - -> Exp () Name - -xLoopGuard xB xCount xF - = xApps (xVarOpLoop OpLoopGuard) [xCount, xB, xF] - - --- Utils ----------------------------------------------------------------------- -xVarOpLoop :: OpLoop -> Exp () Name -xVarOpLoop op - = XVar (UPrim (NameOpLoop op) (typeOpLoop op)) diff --git a/DDC/Core/Flow/Prim/OpPrim.hs b/DDC/Core/Flow/Prim/OpPrim.hs --- a/DDC/Core/Flow/Prim/OpPrim.hs +++ b/DDC/Core/Flow/Prim/OpPrim.hs @@ -1,18 +1,30 @@ module DDC.Core.Flow.Prim.OpPrim ( typePrimCast - , typePrimArith) + , typePrimArith + , typePrimVec + + -- * Compounds + , xvRep + , xvProj + , xvGather + , xvScatter) where import DDC.Core.Flow.Prim.TyConPrim +import DDC.Core.Flow.Prim.TyConFlow +import DDC.Core.Flow.Prim.KiConFlow import DDC.Core.Flow.Prim.Base -import DDC.Core.Compounds.Simple -import DDC.Core.Exp.Simple +import DDC.Core.Flow.Exp.Simple.Compounds +import DDC.Core.Flow.Exp.Simple.Exp -- | Take the type of a primitive cast. typePrimCast :: PrimCast -> Type Name typePrimCast cc = case cc of + PrimCastConvert + -> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFun` t1 + PrimCastPromote -> tForalls [kData, kData] $ \[t1, t2] -> t2 `tFun` t1 @@ -51,3 +63,64 @@ PrimArithBAnd -> tForall kData $ \t -> t `tFun` t `tFun` t PrimArithBOr -> tForall kData $ \t -> t `tFun` t `tFun` t PrimArithBXOr -> tForall kData $ \t -> t `tFun` t `tFun` t + + +-- | Take the type of a primitive vector operator. +typePrimVec :: PrimVec -> Type Name +typePrimVec op + = case op of + PrimVecNeg n -> tForall kData $ \t -> tVec n t `tFun` tVec n t + PrimVecAdd n -> tForall kData $ \t -> tVec n t `tFun` tVec n t `tFun` tVec n t + PrimVecSub n -> tForall kData $ \t -> tVec n t `tFun` tVec n t `tFun` tVec n t + PrimVecMul n -> tForall kData $ \t -> tVec n t `tFun` tVec n t `tFun` tVec n t + PrimVecDiv n -> tForall kData $ \t -> tVec n t `tFun` tVec n t `tFun` tVec n t + + PrimVecRep n + -> tForall kData $ \t -> t `tFun` tVec n t + + PrimVecPack n + -> tForall kData + $ \t -> let Just t' = tFunOfList (replicate n t ++ [tVec n t]) + in t' + + PrimVecProj n _ + -> tForall kData + $ \t -> tVec n t `tFun` t + + PrimVecGather n + -> tForalls [kRate, kData] + $ \[k, t] -> tRateVec k t `tFun` tVec n tNat `tFun` tVec n t + + PrimVecScatter n + -> tForall kData + $ \t -> tVector t `tFun` tVec n tNat `tFun` tVec n t `tFun` tUnit + + +-- Compounds ------------------------------------------------------------------ +xvRep :: Int -> Type Name -> Exp () Name -> Exp () Name +xvRep c tA xZ + = xApps (xVarPrimVec (PrimVecRep c)) + [XType tA, xZ] + +xvProj :: Int -> Int -> Type Name -> Exp () Name -> Exp () Name +xvProj n i tA xV + = xApps (xVarPrimVec (PrimVecProj n i)) + [XType tA, xV] + +xvGather :: Int -> Type Name -> Type Name -> Exp () Name -> Exp () Name -> Exp () Name +xvGather c tK tA xVec xIxs + = xApps (xVarPrimVec (PrimVecGather c)) + [XType tK, XType tA, xVec, xIxs] + + +xvScatter :: Int -> Type Name -> Exp () Name -> Exp () Name -> Exp () Name -> Exp () Name +xvScatter c tA xVec xIxs xElems + = xApps (xVarPrimVec (PrimVecScatter c)) + [XType tA, xVec, xIxs, xElems] + + +-- Utils ----------------------------------------------------------------------- +xVarPrimVec :: PrimVec -> Exp () Name +xVarPrimVec op + = XVar (UPrim (NamePrimVec op) (typePrimVec op)) + diff --git a/DDC/Core/Flow/Prim/OpSeries.hs b/DDC/Core/Flow/Prim/OpSeries.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Prim/OpSeries.hs @@ -0,0 +1,471 @@ + +module DDC.Core.Flow.Prim.OpSeries + ( readOpSeries + , typeOpSeries + + -- Compounds + , xSeriesOfRateVec) +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.Flow.Exp.Simple.Compounds +import DDC.Core.Flow.Exp.Simple.Exp +import DDC.Core.Transform.BoundT +import DDC.Data.Pretty +import Control.DeepSeq +import Data.List +import Data.Char + + +instance NFData OpSeries where + rnf !_ = () + + +instance Pretty OpSeries where + ppr pf + = case pf of + OpSeriesRep -> text "srep" <> text "#" + OpSeriesReps -> text "sreps" <> text "#" + + OpSeriesIndices -> text "sindices" <> text "#" + + OpSeriesFill -> text "sfill" <> text "#" + + OpSeriesGather -> text "sgather" <> text "#" + OpSeriesScatter -> text "sscatter" <> text "#" + + OpSeriesMkSel 1 -> text "smkSel" <> text "#" + OpSeriesMkSel n -> text "smkSel" <> int n <> text "#" + + OpSeriesMkSegd -> text "smkSegd" <> text "#" + + OpSeriesMap 1 -> text "smap" <> text "#" + OpSeriesMap i -> text "smap" <> int i <> text "#" + + OpSeriesPack -> text "spack" <> text "#" + + OpSeriesGenerate -> text "sgenerate" <> text "#" + + OpSeriesReduce -> text "sreduce" <> text "#" + OpSeriesFolds -> text "sfolds" <> text "#" + + OpSeriesJoin -> text "pjoin" <> text "#" + + OpSeriesRunProcess -> text "runProcess" <> text "#" + OpSeriesRunProcessUnit -> text "runProcessUnit" <> text "#" + + OpSeriesRateVecsOfVectors n -> text "ratify" <> int n <> text "#" + + OpSeriesSeriesOfRateVec -> text "series" <> text "#" + OpSeriesAppend -> text "sappend" <> text "#" + OpSeriesCross -> text "scross" <> text "#" + + OpSeriesResizeProc -> text "presize" <> text "#" + OpSeriesResizeId -> text "rid" <> text "#" + OpSeriesResizeAppL -> text "rappl" <> text "#" + OpSeriesResizeAppR -> text "rappr" <> text "#" + OpSeriesResizeApp -> text "rapp" <> text "#" + OpSeriesResizeSel1 -> text "rsel1" <> text "#" + OpSeriesResizeSegd -> text "rsegd" <> text "#" + OpSeriesResizeCross -> text "rcross" <> text "#" + + +-- | Read a data flow operator name. +readOpSeries :: String -> Maybe OpSeries +readOpSeries str + | Just rest <- stripPrefix "smap" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , arity <- read ds + = Just $ OpSeriesMap arity + + | Just rest <- stripPrefix "smkSel" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , arity <- read ds + , arity == 1 + = Just $ OpSeriesMkSel arity + + | Just rest <- stripPrefix "ratify" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , arity <- read ds + = Just $ OpSeriesRateVecsOfVectors arity + + + | otherwise + = case str of + "srep#" -> Just $ OpSeriesRep + "sreps#" -> Just $ OpSeriesReps + "sindices#" -> Just $ OpSeriesIndices + "sgather#" -> Just $ OpSeriesGather + "smkSel#" -> Just $ OpSeriesMkSel 1 + "smkSegd#" -> Just $ OpSeriesMkSegd + "smap#" -> Just $ OpSeriesMap 1 + "spack#" -> Just $ OpSeriesPack + "sgenerate#" -> Just $ OpSeriesGenerate + "sreduce#" -> Just $ OpSeriesReduce + "sfolds#" -> Just $ OpSeriesFolds + "sfill#" -> Just $ OpSeriesFill + "sscatter#" -> Just $ OpSeriesScatter + "pjoin#" -> Just $ OpSeriesJoin + "runProcess#" -> Just $ OpSeriesRunProcess + "runProcessUnit#"->Just $ OpSeriesRunProcessUnit + "series#" -> Just $ OpSeriesSeriesOfRateVec + "sappend#" -> Just $ OpSeriesAppend + "scross#" -> Just $ OpSeriesCross + + "presize#" -> Just $ OpSeriesResizeProc + "rid#" -> Just $ OpSeriesResizeId + "rappl#" -> Just $ OpSeriesResizeAppL + "rappr#" -> Just $ OpSeriesResizeAppR + "rapp#" -> Just $ OpSeriesResizeApp + "rsel1#" -> Just $ OpSeriesResizeSel1 + "rsegd#" -> Just $ OpSeriesResizeSegd + "rcross#" -> Just $ OpSeriesResizeCross + + _ -> Nothing + + +-- Types ----------------------------------------------------------------------- +-- | Yield the type of a data flow operator, +-- or `error` if there isn't one. +typeOpSeries :: OpSeries -> Type Name +typeOpSeries op + = case takeTypeOpSeries op of + Just t -> t + Nothing -> error $ "ddc-core-flow.typeOpSeries: invalid op " ++ show op + + +-- | Yield the type of a data flow operator. +takeTypeOpSeries :: OpSeries -> Maybe (Type Name) +takeTypeOpSeries op + = case op of + -- Replicates ------------------------- + -- rep :: [p : Proc] [k : Rate] [a : Data] + -- . a -> Series p k a + OpSeriesRep + -> Just $ tForalls [kProc, kRate, kData] $ \[tP, tR, tA] + -> tA `tFun` tSeries tP tR tA + + -- reps :: [p : Proc]. [k1 k2 : Rate]. [a : Data] + -- . Segd k1 k2 -> Series p k1 a -> Series p k2 a + OpSeriesReps + -> Just $ tForalls [kProc, kRate, kRate, kData] $ \[tP, tK1, tK2, tA] + -> tSegd tK1 tK2 `tFun` tSeries tP tK1 tA `tFun` tSeries tP tK2 tA + + + -- Indices ------------------------------ + -- indices :: [p : Proc]. [k1 k2 : Rate]. + -- . Segd k1 k2 -> Series p k2 k1 Nat + OpSeriesIndices + -> Just $ tForalls [kProc, kRate, kRate] $ \[tP, tK1, tK2] + -> tSegd tK1 tK2 `tFun` tSeries tP tK2 tNat + + + -- Maps --------------------------------- + -- map :: [p : Proc]. [kR kL : Rate] [a b : Data] + -- . (a -> b) -> Series p kR kL a -> Series p kR kL b + OpSeriesMap 1 + -> Just $ tForalls [kProc, kRate, kData, kData] $ \[tP, tKR, tA, tB] + -> (tA `tFun` tB) + `tFun` tSeries tP tKR tA + `tFun` tSeries tP tKR tB + + -- mapN :: [p : Proc] [kR kL : Rate] [a0..aN : Data] + -- . (a0 -> .. aN) -> Series p kR kL a0 -> .. Series p kR kL aN + OpSeriesMap n + | n >= 2 + , Just tWork <- tFunOfList + [ TVar (UIx i) + | i <- reverse [0..n] ] + + , Just tBody <- tFunOfList + (tWork : [tSeries (TVar $ UIx $ n + 2) (TVar $ UIx $ n + 1) + (TVar $ UIx i) + | i <- reverse [0..n] ]) + + -> Just $ foldr TForall tBody + [ BAnon k | k <- kProc : kRate : replicate (n + 1) kData ] + + + -- Packs -------------------------------- + -- pack :: [p : Proc]. [k1 k2 kL : Rate]. [a : Data] + -- . Sel2 k1 k2 + -- -> Series p k1 kL a -> Series p k2 kL a + OpSeriesPack + -> Just $ tForalls [kProc, kRate, kRate, kData] $ \[tP, tK1, tK2, tA] + -> tSel1 tP tK1 tK2 + `tFun` tSeries tP tK1 tA + `tFun` tSeries tP tK2 tA + + + -- Processes ---------------------------- + -- join# :: [p : Proc]. [k : Rate]. [a b : Data]. + -- . Process p k a + -- -> Process p k b + -- -> Process p k (a,b) + OpSeriesJoin + -> Just $ tForalls [kProc, kRate] $ + \[tP, tK] + -> tProcess tP tK + `tFun` tProcess tP tK + `tFun` tProcess tP tK + + + -- mkSel1# :: [p : Proc]. [k1 kL : Rate] + -- . Series p k1 kL Bool# + -- -> ([k2 : Rate]. Sel1 p k1 k2 -> Process# p kL) + -- -> Process# p kL + OpSeriesMkSel 1 + -> Just $ tForalls [kProc, kRate, kRate] $ \[tP, tK1, tKL] + -> tSeries tP tK1 tBool + `tFun` (tForall kRate $ \tK2 + -> tSel1 (liftT 1 tP) (liftT 1 tK1) tK2 `tFun` tProcess (liftT 1 tP) (liftT 1 tKL)) + `tFun` tProcess tP tKL + + + -- mkSegd# :: [p : Proc]. [k1 kL : Rate] + -- . Series# p k1 kL Nat# + -- -> ([k2 : Rate]. Segd# k1 k2 -> Process# p kL) + -- -> Process# p kL + OpSeriesMkSegd + -> Just $ tForalls [kProc, kRate] $ \[tP, tK1] + -> tSeries tP tK1 tNat + `tFun` (tForall kRate $ \tK2 + -> tSegd (liftT 1 tK1) tK2 `tFun` tProcess (liftT 1 tP) (liftT 1 tK1)) + `tFun` tProcess tP tK1 + + + -- runProcess# :: [k : Rate] + -- . + -- ([p : Proc]. Unit -> Process p k) + -- -> Unit + OpSeriesRunProcess + -> Just $ tForalls [kRate] $ \[tK] + -> (tForall kProc $ \tP + -> tUnit `tFun` tProcess tP (liftT 1 tK)) + `tFun` tUnit + + -- runProcessUnit# :: [k : Rate] + -- . + -- ([p : Proc]. Unit -> Unit) + -- -> Unit + OpSeriesRunProcessUnit + -> Just $ tForalls [kRate] $ \[_] + -> (tForall kProc $ \_ + -> tUnit `tFun` tUnit) + `tFun` tUnit + + + -- ratify0# :: [z : Data] + -- . Nat + -- -> ([k : Rate]. z) + -- -> z + OpSeriesRateVecsOfVectors 0 + -> Just $ tForall kData $ \tA + -> tNat + `tFun` (tForall kRate $ \_ -> liftT 1 tA) + `tFun` tA + + -- ratifyN# :: [a0..aN z : Data] + -- . Vector a0 .. Vector aN + -- -> ([k : Rate]. RateVec k a0 .. RateVec k aN -> z) + -- -> z + OpSeriesRateVecsOfVectors n + | tK <- TVar (UIx 0) + + , Just tWork <- tFunOfList + $ [ tRateVec tK (TVar (UIx i)) + | i <- reverse [2..n+1] ] + ++[ TVar (UIx 1) ] + + , tWork' <- TForall (BAnon kRate) tWork + + , Just tBody <- tFunOfList + $ [ tVector (TVar (UIx i)) | i <- reverse [1..n] ] + ++[ tWork', TVar (UIx 0) ] + + -> Just $ foldr TForall tBody + [ BAnon k | k <- replicate (n+1) kData ] + + -- series# :: [p : Proc]. [k : Rate]. [a : Data] + -- . RateVec k a -> Series p k a + OpSeriesSeriesOfRateVec + -> Just $ tForalls [kProc, kRate, kData] $ \[tP, tK, tA] + -> tRateVec tK tA `tFun` tSeries tP tK tA + + -- sappend# :: [p : Proc]. [k1R k2R : Rate]. [a : Data] + -- . Series p k1R a -> Series p k2R a + -- -> Series p (k1R + k2R) a + OpSeriesAppend + -> Just $ tForalls [kProc, kRate, kRate, kData] $ + \[tP, tK1, tK2, tA] + -> tSeries tP tK1 tA + `tFun` tSeries tP tK2 tA + `tFun` tSeries tP (tRateAppend tK1 tK2) tA + + -- scross# :: [p : Proc]. [kR kO : Rate]. [a b : Data] + -- . Series p kR a + -- -> RateVec kO b + -- -> Series p (kR * kO) (a,b) + OpSeriesCross + -> Just $ tForalls [kProc, kRate, kRate, kData, kData] $ + \[tP, tKR, tKO, tA, tB] + -> tSeries tP tKR tA + `tFun` tRateVec tKO tB + `tFun` tSeries tP (tRateCross tKR tKO) (tTuple2 tA tB) + + + -- generate# :: [p : Proc]. [k : Rate]. [a : Data] + -- . (Nat# -> a) -> Series p k a + OpSeriesGenerate + -> Just $ tForalls [kProc, kRate, kData] $ \[tP, tK, tA] + -> (tNat `tFun` tA) + `tFun` tSeries tP tK tA + + -- Reductions ------------------------------- + -- reduce# :: [p : Proc]. [k : Rate]. [a : Data] + -- . Ref a -> (a -> a -> a) -> a -> Series p k a -> Process p k + OpSeriesReduce + -> Just $ tForalls [kProc, kRate, kData] $ \[tP, tK, tA] + -> tRef tA + `tFun` (tA `tFun` tA `tFun` tA) + `tFun` tA + `tFun` tSeries tP tK tA + `tFun` tProcess tP tK + + + -- folds# :: [p : Proc]. [k1 k2 : Rate]. [a : Data] + -- . Segd# k1 k2 -> Series p k1 a -> Series k2 b + OpSeriesFolds + -> Just $ tForalls [kProc, kRate, kRate, kData] $ \[tP, tK1, tK2, tA] + -> tSegd tK1 tK2 + `tFun` tSeries tP tK1 tA + `tFun` tSeries tP tK2 tA + + + -- Store operators --------------------------- + -- scatter# :: [p : Proc]. [k : Rate]. [a : Data] + -- . Vector a -> Series p k Nat# -> Series p k a -> Process p k + OpSeriesScatter + -> Just $ tForalls [kProc, kRate, kData] $ \[tP, tK, tA] + -> tVector tA + `tFun` tSeries tP tK tNat + `tFun` tSeries tP tK tA + `tFun` tProcess tP tK + + + -- gather# :: [p : Proc]. [k1 k2 : Rate]. [a : Data] + -- . RateVec k1 a -> Series p k2 Nat# -> Series p k2 a + OpSeriesGather + -> Just $ tForalls [kProc, kRate, kRate, kData] $ \[tP, tK1, tK2, tA] + -> tRateVec tK1 tA + `tFun` tSeries tP tK2 tNat + `tFun` tSeries tP tK2 tA + + + -- fill# :: [p : Proc]. [k : Rate]. [a : Data]. Vector a -> Series p k a -> Process p k + OpSeriesFill + -> Just $ tForalls [kProc, kRate, kData] $ \[tP, tK, tA] + -> tVector tA + `tFun` tSeries tP tK tA + `tFun` tProcess tP tK + + + -- Resizing ----------------------- + + -- presize# :: [p : Proc]. [j k : Rate] + -- . Resize p j k + -- -> Process p j + -- -> Process p k + OpSeriesResizeProc + -> Just $ tForalls [kProc, kRate, kRate] $ + \[tP, tJ, tK] + -> tResize tP tJ tK + `tFun` tProcess tP tJ + `tFun` tProcess tP tK + + -- rid# :: [p : Proc]. [k : Rate] + -- . Resize p k k + OpSeriesResizeId + -> Just $ tForalls [kProc, kRate] $ + \[tP, tK] + -> tResize tP tK tK + + -- rappl# :: [p : Proc]. [k l : Rate] + -- . Resize p k (Append k l) + OpSeriesResizeAppL + -> Just $ tForalls [kProc, kRate, kRate] $ + \[tP, tK, tL] + -> tResize tP tK (tRateAppend tK tL) + + -- rappr# :: [p : Proc]. [k l : Rate] + -- . Resize p l (Append k l) + OpSeriesResizeAppR + -> Just $ tForalls [kProc, kRate, kRate] $ + \[tP, tK, tL] + -> tResize tP tL (tRateAppend tK tL) + + + -- rapp# :: [p : Proc]. [k k' l l' : Rate] + -- . Resize k k' + -- -> Resize l l' + -- -> Resize (Append k l) (Append k' l') + OpSeriesResizeApp + -> Just $ tForalls [kProc, kRate, kRate, kRate, kRate] $ + \[tP, tK, tK', tL, tL'] + -> tResize tP tK tK' + `tFun` tResize tP tL tL' + `tFun` tResize tP (tRateAppend tK tL) (tRateAppend tK' tL') + + -- rsel1# :: [p : Proc]. [j k l : Rate] + -- . Sel1 p k l + -- -> Resize p j l + -- -> Resize p j k + OpSeriesResizeSel1 + -> Just $ tForalls [kProc, kRate, kRate, kRate] $ + \[tP, tJ, tK, tL] + -> tSel1 tP tK tL + `tFun` tResize tP tJ tL + `tFun` tResize tP tJ tK + + -- rsegd# :: [p : Proc]. [j k l : Rate] + -- . Segd k l + -- -> Resize p j l + -- -> Resize p j k + OpSeriesResizeSegd + -> Just $ tForalls [kProc, kRate, kRate, kRate] $ + \[tP, tJ, tK, tL] + -> tSegd tK tL + `tFun` tResize tP tJ tL + `tFun` tResize tP tJ tK + + -- rcross# :: [p : Proc]. [j k l : Rate] + -- . Resize p j (Cross k l) + -- -> Resize p j k + OpSeriesResizeCross + -> Just $ tForalls [kProc, kRate, kRate, kRate] $ + \[tP, tJ, tK, tL] + -> tResize tP tJ (tRateCross tK tL) + `tFun` tResize tP tJ tK + + + + _ -> Nothing + + +-- Compounds ------------------------------------------------------------------ +xSeriesOfRateVec :: Type Name -> Type Name -> Type Name -> Exp () Name -> Exp () Name +xSeriesOfRateVec tP tK tA xV + = xApps (xVarOpSeries OpSeriesSeriesOfRateVec) + [XType tP, XType tK, XType tA, xV] + + +-- Utils ----------------------------------------------------------------------- +xVarOpSeries :: OpSeries -> Exp () Name +xVarOpSeries op + = XVar (UPrim (NameOpSeries op) (typeOpSeries op)) + diff --git a/DDC/Core/Flow/Prim/OpStore.hs b/DDC/Core/Flow/Prim/OpStore.hs --- a/DDC/Core/Flow/Prim/OpStore.hs +++ b/DDC/Core/Flow/Prim/OpStore.hs @@ -3,22 +3,27 @@ ( OpStore (..) , readOpStore , typeOpStore - , xNew, xRead, xWrite - , xNewVector, xReadVector, xWriteVector, xNewVectorR, xNewVectorN - , xSliceVector - , xNext) + , xNew, xRead, xWrite + , xNewVector, xNewVectorR, xNewVectorN + , xReadVector, xReadVectorC + , xWriteVector, xWriteVectorC + , xTailVector + , xTruncVector + , xBufOfVector, xBufOfRateVec) 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 DDC.Core.Flow.Exp.Simple.Compounds +import DDC.Core.Flow.Exp.Simple.Exp +import DDC.Data.Pretty import Control.DeepSeq - +import Data.List +import Data.Char -instance NFData OpStore +instance NFData OpStore where + rnf !_ = () instance Pretty OpStore where @@ -30,43 +35,74 @@ OpStoreWrite -> text "write#" -- Vectors. - OpStoreNewVector -> text "newVector#" - OpStoreNewVectorR -> text "newVectorR#" - OpStoreNewVectorN -> text "newVectorN#" - OpStoreReadVector -> text "readVector#" - OpStoreWriteVector -> text "writeVector#" - OpStoreSliceVector -> text "sliceVector#" + OpStoreNewVector -> text "vnew#" + OpStoreNewVectorR -> text "vnewR#" + OpStoreNewVectorN -> text "vnewN#" - -- Streams. - OpStoreNext -> text "next#" + OpStoreReadVector 1 -> text "vread#" + OpStoreReadVector n -> text "vread$" <> int n <> text "#" + OpStoreWriteVector 1 -> text "vwrite#" + OpStoreWriteVector n -> text "vwrite$" <> int n <> text "#" + OpStoreTailVector 1 -> text "vtail#" + OpStoreTailVector n -> text "vtail" <> int n <> text "#" + + OpStoreTruncVector -> text "vtrunc#" + OpStoreBufOfVector -> text "vbuf#" + OpStoreBufOfRateVec -> text "vbufofratevec#" + + -- | Read a store operator name. readOpStore :: String -> Maybe OpStore readOpStore str - = case str of - "new#" -> Just OpStoreNew - "read#" -> Just OpStoreRead - "write#" -> Just OpStoreWrite + | Just rest <- stripPrefix "vread$" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + , n >= 1 + = Just $ OpStoreReadVector n - "newVector#" -> Just OpStoreNewVector - "newVectorR#" -> Just OpStoreNewVectorR - "newVectorN#" -> Just OpStoreNewVectorN - "readVector#" -> Just OpStoreReadVector - "writeVector#" -> Just OpStoreWriteVector - "sliceVector#" -> Just OpStoreSliceVector + | Just rest <- stripPrefix "vwrite$" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + , n >= 1 + = Just $ OpStoreWriteVector n - "next#" -> Just OpStoreNext - _ -> Nothing + | Just rest <- stripPrefix "vtail$" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + , n >= 1 + = Just $ OpStoreTailVector n + | otherwise + = case str of + "new#" -> Just OpStoreNew + "read#" -> Just OpStoreRead + "write#" -> Just OpStoreWrite + + "vnew#" -> Just OpStoreNewVector + "vnewR#" -> Just OpStoreNewVectorR + "vnewN#" -> Just OpStoreNewVectorN + "vread#" -> Just (OpStoreReadVector 1) + "vwrite#" -> Just (OpStoreWriteVector 1) + "vtail#" -> Just (OpStoreTailVector 1) + "vtrunc#" -> Just OpStoreTruncVector + "vbuf#" -> Just OpStoreBufOfVector + "vbufofratevec#"-> Just OpStoreBufOfRateVec + _ -> Nothing + + -- Types ---------------------------------------------------------------------- -- | Yield the type of a store operator. typeOpStore :: OpStore -> Type Name typeOpStore op = case op of -- Assignables ---------------- - -- new# :: [a : Data]. a -> Array# a + -- new# :: [a : Data]. a -> Ref# a OpStoreNew -> tForall kData $ \tA -> tA `tFun` tRef tA @@ -79,43 +115,62 @@ -> tForall kData $ \tA -> tRef tA `tFun` tA `tFun` tUnit -- Arrays --------------------- - -- newVector# :: [a : Data]. Nat -> Vector# a + -- vnew# :: [a : Data]. Nat -> Vector# a OpStoreNewVector -> tForall kData $ \tA -> tNat `tFun` tVector tA - -- newVectorR# :: [a : Data]. [k : Rate]. Vector# a + -- vnew# :: [a : Data]. [k : Rate]. Vector# a OpStoreNewVectorR -> tForalls [kData, kRate] $ \[tA, _] -> tVector tA - -- newVectorN# :: [a : Data]. [k : Rate]. RateNat k -> Vector a + -- vnew# :: [a : Data]. [k : Rate]. RateNat k -> Vector a OpStoreNewVectorN -> tForalls [kData, kRate] $ \[tA, tK] -> tRateNat tK `tFun` tVector tA - -- readVector# :: [a : Data]. Vector# a -> Nat# -> a - OpStoreReadVector + -- vread# :: [a : Data]. Vector# a -> Nat# -> a + OpStoreReadVector 1 -> tForall kData - $ \tA -> tVector tA `tFun` tNat `tFun` tA + $ \tA -> tBuffer tA `tFun` tNat `tFun` tA - -- writeVector# :: [a : Data]. Vector# a -> Nat# -> a -> Unit - OpStoreWriteVector + -- vreadN# :: [a : Data]. Vector# a -> Nat# -> VecN# a + OpStoreReadVector n -> tForall kData - $ \tA -> tVector tA `tFun` tNat `tFun` tA `tFun` tUnit + $ \tA -> tBuffer tA `tFun` tNat `tFun` tVec n tA - -- sliceVector# :: [a : Data]. Nat# -> Vector# a -> Vector# a - OpStoreSliceVector + -- vwrite# :: [a : Data]. Vector# a -> Nat# -> a -> Unit + OpStoreWriteVector 1 -> tForall kData - $ \tA -> tNat `tFun` tVector tA `tFun` tVector tA + $ \tA -> tBuffer tA `tFun` tNat `tFun` tA `tFun` tUnit + -- vwriteN# :: [a : Data]. Vector# a -> Nat# -> VecN# a -> Unit + OpStoreWriteVector n + -> tForall kData + $ \tA -> tBuffer tA `tFun` tNat `tFun` tVec n tA `tFun` tUnit - -- Streams -------------------- - -- next# :: [a : Data]. [k : Rate]. Series# k a -> Nat# -> a - OpStoreNext - -> tForalls [kData, kRate] - $ \[tA, tK] -> tSeries tK tA `tFun` tNat `tFun` tA + -- vtail$N# :: [k : Rate]. [a : Data]. RateNat (TailN k) -> Vector# a -> Vector# a + OpStoreTailVector n + -> tForalls [kRate, kData] + $ \[tK, tA] -> tRateNat (tTail n tK) `tFun` tVector tA `tFun` tVector tA + -- vtrunc# :: [a : Data]. Nat# -> Vector# a -> Unit + OpStoreTruncVector + -> tForall kData + $ \tA -> tNat `tFun` tVector tA `tFun` tUnit + -- vbuf# :: [a : Data]. Vector# a -> Buffer# a + OpStoreBufOfVector + -> tForall kData + $ \tA -> tVector tA `tFun` tBuffer tA + + -- vbufofratevec# :: [k : Rate]. [a : Data]. RateVec# k a -> Buffer# a + OpStoreBufOfRateVec + -> tForalls [kRate, kData] + $ \[tK, tA] -> tRateVec tK tA `tFun` tBuffer tA + + + -- Compounds ------------------------------------------------------------------ xNew :: Type Name -> Exp () Name -> Exp () Name xNew t xV @@ -155,25 +210,50 @@ xReadVector :: Type Name -> Exp () Name -> Exp () Name -> Exp () Name xReadVector t xArr xIx - = xApps (xVarOpStore OpStoreReadVector) + = xApps (xVarOpStore (OpStoreReadVector 1)) [XType t, xArr, xIx] +xReadVectorC :: Int -> Type Name -> Exp () Name -> Exp () Name -> Exp () Name +xReadVectorC c t xArr xIx + = xApps (xVarOpStore (OpStoreReadVector c)) + [XType t, xArr, xIx] + + xWriteVector :: Type Name -> Exp () Name -> Exp () Name -> Exp () Name -> Exp () Name xWriteVector t xArr xIx xElem - = xApps (xVarOpStore OpStoreWriteVector) + = xApps (xVarOpStore (OpStoreWriteVector 1)) [XType t, xArr, xIx, xElem] -xSliceVector :: Type Name -> Exp () Name -> Exp () Name -> Exp () Name -xSliceVector tElem xLen xArr - = xApps (xVarOpStore OpStoreSliceVector) + +xWriteVectorC :: Int -> Type Name -> Exp () Name -> Exp () Name -> Exp () Name -> Exp () Name +xWriteVectorC c t xArr xIx xElem + = xApps (xVarOpStore (OpStoreWriteVector c)) + [XType t, xArr, xIx, xElem] + + +xTailVector :: Int -> Type Name -> Type Name -> Exp () Name -> Exp () Name -> Exp () Name +xTailVector n tK tA xRN xVec + = xApps (xVarOpStore (OpStoreTailVector n)) + [XType tK, XType tA, xRN, xVec] + + +xTruncVector :: Type Name -> Exp () Name -> Exp () Name -> Exp () Name +xTruncVector tElem xLen xArr + = xApps (xVarOpStore OpStoreTruncVector) [XType tElem, xLen, xArr] +xBufOfVector :: Type Name -> Exp () Name -> Exp () Name +xBufOfVector tElem xArr + = xApps (xVarOpStore OpStoreBufOfVector) + [XType tElem, 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] +xBufOfRateVec :: Type Name -> Type Name -> Exp () Name -> Exp () Name +xBufOfRateVec tRate tElem xArr + = xApps (xVarOpStore OpStoreBufOfRateVec) + [XType tRate, XType tElem, xArr] + + -- Utils ---------------------------------------------------------------------- diff --git a/DDC/Core/Flow/Prim/OpVector.hs b/DDC/Core/Flow/Prim/OpVector.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Prim/OpVector.hs @@ -0,0 +1,135 @@ +module DDC.Core.Flow.Prim.OpVector + ( readOpVector + , typeOpVector) +where +import DDC.Core.Flow.Prim.TyConFlow +import DDC.Core.Flow.Prim.TyConPrim +import DDC.Core.Flow.Prim.Base +import DDC.Core.Flow.Exp.Simple.Compounds +import DDC.Core.Flow.Exp.Simple.Exp +import DDC.Data.Pretty +import Control.DeepSeq +import Data.List +import Data.Char + + +instance NFData OpVector where + rnf !_ = () + + +instance Pretty OpVector where + ppr pf + = case pf of + OpVectorMap 1 -> text "vmap" <> text "#" + OpVectorMap i -> text "vmap" <> int i <> text "#" + + OpVectorFilter -> text "vfilter" <> text "#" + + OpVectorReduce -> text "vreduce" <> text "#" + + OpVectorGenerate -> text "vgenerate" <> text "#" + OpVectorLength -> text "vlength" <> text "#" + + OpVectorGather -> text "vgather" <> text "#" + + +-- | Read a data flow operator name. +readOpVector :: String -> Maybe OpVector +readOpVector str + | Just rest <- stripPrefix "vmap" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , arity <- read ds + = Just $ OpVectorMap arity + + | otherwise + = case str of + "vmap#" -> Just $ OpVectorMap 1 + "vfilter#" -> Just $ OpVectorFilter + "vreduce#" -> Just $ OpVectorReduce + "vgenerate#" -> Just $ OpVectorGenerate + "vlength#" -> Just $ OpVectorLength + "vgather#" -> Just $ OpVectorGather + _ -> Nothing + + +-- Types ----------------------------------------------------------------------- +-- | Yield the type of a data flow operator, +-- or `error` if there isn't one. +typeOpVector :: OpVector -> Type Name +typeOpVector op + = case takeTypeOpVector op of + Just t -> t + Nothing -> error $ "ddc-core-flow.typeOpVector: invalid op " ++ show op + + +-- | Yield the type of a data flow operator. +takeTypeOpVector :: OpVector -> Maybe (Type Name) +takeTypeOpVector op + = case op of + -- Maps --------------------------------- + -- map :: [a b : Data] + -- . (a -> b) -> Vector a -> Vector b + OpVectorMap 1 + -> Just $ tForalls [kData, kData] $ \[tA, tB] + -> (tA `tFun` tB) + `tFun` tVector tA + `tFun` tVector tB + + -- mapN :: [a0..aN : Data] + -- . (a0 -> .. aN) -> Vector a0 -> .. Vector aN + OpVectorMap n + | n >= 2 + , Just tWork <- tFunOfList + [ TVar (UIx i) + | i <- reverse [0..n] ] + + , Just tBody <- tFunOfList + (tWork : [tVector (TVar (UIx i)) + | i <- reverse [0..n] ]) + + -> Just $ foldr TForall tBody + [ BAnon k | k <- replicate (n + 1) kData ] + + -- Selectors ---------------------------- + -- filter# :: [a : Data] + -- . Vector a + -- -> (a -> Bool#) + -- -> Vector a + OpVectorFilter + -> Just $ tForalls [kData] $ \[tA] + -> (tA `tFun` tBool) + `tFun` tVector tA + `tFun` tVector tA + + -- reduce# :: [a: Data] + -- . (a -> a -> a) -> a -> Vector a -> a + OpVectorReduce + -> Just $ tForalls [kData] $ \[tA] + -> (tA `tFun` tA `tFun` tA) + `tFun` tA + `tFun` tVector tA + `tFun` tA + + -- Vector creation and filling ---------- + -- generate :: [a : Data]. Nat# -> (Nat# -> a) -> Vector a + OpVectorGenerate + -> Just $ tForalls [kData] $ \[tA] + -> tNat + `tFun` (tNat `tFun` tA) + `tFun` tVector tA + + -- length :: [a : Data]. Vector a -> Nat# + OpVectorLength + -> Just $ tForalls [kData] $ \[tA] + -> tVector tA `tFun` tNat + + -- gather :: [a : Data]. Vector a -> Vector Nat# -> Vector a + OpVectorGather + -> Just $ tForalls [kData] $ \[tA] + -> tVector tA + `tFun` tVector tNat + `tFun` tVector tA + + _ -> Nothing + diff --git a/DDC/Core/Flow/Prim/TyConFlow.hs b/DDC/Core/Flow/Prim/TyConFlow.hs --- a/DDC/Core/Flow/Prim/TyConFlow.hs +++ b/DDC/Core/Flow/Prim/TyConFlow.hs @@ -3,42 +3,70 @@ ( TyConFlow (..) , readTyConFlow , kindTyConFlow + + -- * Predicates + , isRateNatType + , isSeriesType + , isRefType + , isVectorType + , isRateVecType + , isBufferType + , isProcessType + + -- * Compounds , tTuple1 , tTuple2 , tTupleN , tVector + , tBuffer + , tRateVec , tSeries , tSegd , tSel1 , tSel2 , tRef , tWorld - , tRateNat) + , tRateNat + , tRateAppend + , tRateCross + , tDown + , tTail + , tProcess + , tResize) 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 DDC.Core.Flow.Exp.Simple.Compounds +import DDC.Core.Flow.Exp.Simple.Exp +import DDC.Data.Pretty import Control.DeepSeq import Data.Char import Data.List -instance NFData TyConFlow +instance NFData TyConFlow where + rnf !_ = () instance Pretty TyConFlow where ppr dc = case dc of - TyConFlowTuple n -> text "Tuple" <> int n <> text "#" + TyConFlowTuple n -> text "Tuple" <> int n <> text "#" + TyConFlowBuffer -> text "Buffer#" TyConFlowVector -> text "Vector#" + TyConFlowRateVec -> text "RateVec#" TyConFlowSeries -> text "Series#" TyConFlowSegd -> text "Segd#" - TyConFlowSel n -> text "Sel" <> int n <> text "#" + TyConFlowSel n -> text "Sel" <> int n <> text "#" TyConFlowRef -> text "Ref#" TyConFlowWorld -> text "World#" TyConFlowRateNat -> text "RateNat#" + TyConFlowRateCross -> text "RateCross#" + TyConFlowRateAppend -> text "RateAppend#" + TyConFlowDown n -> text "Down" <> int n <> text "#" + TyConFlowTail n -> text "Tail" <> int n <> text "#" + TyConFlowProcess -> text "Process#" + TyConFlowResize -> text "Resize#" -- | Read a type constructor name. @@ -50,15 +78,33 @@ , arity <- read ds = Just $ TyConFlowTuple arity + | Just rest <- stripPrefix "Down" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + = Just $ TyConFlowDown n + + | Just rest <- stripPrefix "Tail" str + , (ds, "#") <- span isDigit rest + , not $ null ds + , n <- read ds + = Just $ TyConFlowTail n + | otherwise = case str of + "Buffer#" -> Just $ TyConFlowBuffer "Vector#" -> Just $ TyConFlowVector + "RateVec#" -> Just $ TyConFlowRateVec "Series#" -> Just $ TyConFlowSeries "Segd#" -> Just $ TyConFlowSegd "Sel1#" -> Just $ TyConFlowSel 1 "Ref#" -> Just $ TyConFlowRef "World#" -> Just $ TyConFlowWorld "RateNat#" -> Just $ TyConFlowRateNat + "RateCross#" -> Just $ TyConFlowRateCross + "RateAppend#" -> Just $ TyConFlowRateAppend + "Process#" -> Just $ TyConFlowProcess + "Resize#" -> Just $ TyConFlowResize _ -> Nothing @@ -68,15 +114,79 @@ kindTyConFlow tc = case tc of TyConFlowTuple n -> foldr kFun kData (replicate n kData) - TyConFlowVector -> kData `kFun` kData - TyConFlowSeries -> kRate `kFun` kData `kFun` kData + TyConFlowBuffer -> kData `kFun` kData + TyConFlowVector -> kData `kFun` kData + TyConFlowRateVec -> kRate `kFun` kData `kFun` kData + TyConFlowSeries -> kProc `kFun` kRate `kFun` kData `kFun` kData TyConFlowSegd -> kRate `kFun` kRate `kFun` kData - TyConFlowSel n -> foldr kFun kData (replicate (n + 1) kRate) + TyConFlowSel n -> kProc `kFun` foldr kFun kData (replicate (n + 1) kRate) TyConFlowRef -> kData `kFun` kData TyConFlowWorld -> kData TyConFlowRateNat -> kRate `kFun` kData + TyConFlowRateCross -> kRate `kFun` kRate `kFun` kRate + TyConFlowRateAppend -> kRate `kFun` kRate `kFun` kRate + TyConFlowDown{} -> kRate `kFun` kRate + TyConFlowTail{} -> kRate `kFun` kRate + TyConFlowProcess -> kProc `kFun` kRate `kFun` kData + TyConFlowResize -> kProc `kFun` kRate `kFun` kRate `kFun` kData +-- Predicates ----------------------------------------------------------------- +-- | Check if some type is a fully applied type of a RateNat +isRateNatType :: Type Name -> Bool +isRateNatType tt + = case takePrimTyConApps tt of + Just (NameTyConFlow TyConFlowRateNat, [_]) -> True + _ -> False + + +-- | Check if some type is a fully applied type of a Series. +isSeriesType :: Type Name -> Bool +isSeriesType tt + = case takePrimTyConApps tt of + Just (NameTyConFlow TyConFlowSeries, [_, _, _]) -> True + _ -> False + + +-- | Check if some type is a fully applied type of a Ref. +isRefType :: Type Name -> Bool +isRefType tt + = case takePrimTyConApps tt of + Just (NameTyConFlow TyConFlowRef, [_]) -> True + _ -> False + + +-- | Check if some type is a fully applied type of a Vector. +isVectorType :: Type Name -> Bool +isVectorType tt + = case takePrimTyConApps tt of + Just (NameTyConFlow TyConFlowVector, [_]) -> True + _ -> False + + +-- | Check if some type is a fully applied type of a Buffer. +isBufferType :: Type Name -> Bool +isBufferType tt + = case takePrimTyConApps tt of + Just (NameTyConFlow TyConFlowBuffer, [_]) -> True + _ -> False + +-- | Check if some type is a fully applied type of a RateVec. +isRateVecType :: Type Name -> Bool +isRateVecType tt + = case takePrimTyConApps tt of + Just (NameTyConFlow TyConFlowRateVec, [_, _])-> True + _ -> False + +-- | Check if some type is a fully applied Process. +isProcessType :: Type Name -> Bool +isProcessType tt + = case takePrimTyConApps tt of + Just (NameTyConFlow TyConFlowProcess, [_, _]) -> True + _ -> False + + + -- Compounds ------------------------------------------------------------------ tTuple1 :: Type Name -> Type Name tTuple1 tA = tApps (tConTyConFlow (TyConFlowTuple 1)) [tA] @@ -90,24 +200,31 @@ tTupleN tys = tApps (tConTyConFlow (TyConFlowTuple (length tys))) tys -tVector :: Type Name -> Type Name +tBuffer :: Type Name -> Type Name +tBuffer tA = tApps (tConTyConFlow TyConFlowBuffer) [tA] + + +tVector :: Type Name -> Type Name tVector tA = tApps (tConTyConFlow TyConFlowVector) [tA] +tRateVec :: Type Name -> Type Name -> Type Name +tRateVec tK tA = tApps (tConTyConFlow TyConFlowRateVec) [tK, tA] -tSeries :: Type Name -> Type Name -> Type Name -tSeries tK tA = tApps (tConTyConFlow TyConFlowSeries) [tK, tA] +tSeries :: Type Name -> Type Name -> Type Name -> Type Name +tSeries tP tK tA = tApps (tConTyConFlow TyConFlowSeries) [tP, 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] +tSel1 :: Type Name -> Type Name -> Type Name -> Type Name +tSel1 tP tK1 tK2 = tApps (tConTyConFlow $ TyConFlowSel 1) [tP, tK1, tK2] -tSel2 :: Type Name -> Type Name -> Type Name -> Type Name -tSel2 tK1 tK2 tK3 = tApps (tConTyConFlow $ TyConFlowSel 2) [tK1, tK2, tK3] +tSel2 :: Type Name -> Type Name -> Type Name -> Type Name -> Type Name +tSel2 tP tK1 tK2 tK3 = tApps (tConTyConFlow $ TyConFlowSel 2) [tP, tK1, tK2, tK3] tRef :: Type Name -> Type Name @@ -119,7 +236,31 @@ tRateNat :: Type Name -> Type Name -tRateNat tK = tApps (tConTyConFlow TyConFlowRateNat) [tK] +tRateNat tK = tApp (tConTyConFlow TyConFlowRateNat) tK + +tRateCross :: Type Name -> Type Name -> Type Name +tRateCross tKa tKb = tConTyConFlow TyConFlowRateCross `tApps` [tKa, tKb] + +tRateAppend :: Type Name -> Type Name -> Type Name +tRateAppend tKa tKb = tConTyConFlow TyConFlowRateAppend `tApps` [tKa, tKb] + + + +tDown :: Int -> Type Name -> Type Name +tDown n tK = tApp (tConTyConFlow $ TyConFlowDown n) tK + + +tTail :: Int -> Type Name -> Type Name +tTail n tK = tApp (tConTyConFlow $ TyConFlowTail n) tK + + +tProcess :: Type Name -> Type Name -> Type Name +tProcess tP tK = (tConTyConFlow TyConFlowProcess) `tApps` [tP, tK] + +tResize :: Type Name -> Type Name -> Type Name -> Type Name +tResize tP tJ tK = (tConTyConFlow TyConFlowResize) `tApps` [tP, tJ, tK] + + -- Utils ---------------------------------------------------------------------- diff --git a/DDC/Core/Flow/Prim/TyConPrim.hs b/DDC/Core/Flow/Prim/TyConPrim.hs --- a/DDC/Core/Flow/Prim/TyConPrim.hs +++ b/DDC/Core/Flow/Prim/TyConPrim.hs @@ -5,11 +5,13 @@ , tBool , tNat , tInt - , tWord) + , tFloat + , tWord + , tVec) where import DDC.Core.Flow.Prim.Base -import DDC.Core.Compounds.Simple -import DDC.Core.Exp.Simple +import DDC.Core.Flow.Exp.Simple.Compounds +import DDC.Core.Flow.Exp.Simple.Exp -- | Yield the kind of a type constructor. @@ -17,15 +19,17 @@ kindPrimTyCon tc = case tc of PrimTyConVoid -> kData - PrimTyConPtr -> (kRegion `kFun` kData `kFun` kData) + PrimTyConPtr -> kRegion `kFun` kData `kFun` kData PrimTyConAddr -> kData PrimTyConBool -> kData PrimTyConNat -> kData PrimTyConInt -> kData + PrimTyConSize -> kData PrimTyConWord _ -> kData PrimTyConFloat _ -> kData PrimTyConTag -> kData - PrimTyConString -> kData + PrimTyConTextLit -> kData + PrimTyConVec _ -> kData `kFun` kData -- Compounds ------------------------------------------------------------------ @@ -40,18 +44,35 @@ -- | Primitive Nat# type. tNat :: Type Name -tNat = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConInt) kData) kData) +tNat = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConNat) kData) kData) -- | Primitive `Int#` type. tInt :: Type Name -tInt = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConInt) kData) kData) +tInt = TCon (TyConBound (UPrim (NamePrimTyCon PrimTyConInt) kData) kData) +-- | Primitive `FloatN#` type of the given width. +tFloat :: Int -> Type Name +tFloat bits + = TCon (TyConBound (UPrim (NamePrimTyCon (PrimTyConFloat bits)) kData) kData) + + -- | Primitive `WordN#` type of the given width. tWord :: Int -> Type Name tWord bits = TCon (TyConBound (UPrim (NamePrimTyCon (PrimTyConWord bits)) kData) kData) +-- | Primitive @VecN# a@. +tVec :: Int -> Type Name -> Type Name +tVec n tA = TApp (tConPrimTyCon (PrimTyConVec n)) tA + +-- Utils ---------------------------------------------------------------------- +tConPrimTyCon :: PrimTyCon -> Type Name +tConPrimTyCon tcp + = let k = kindPrimTyCon tcp + u = UPrim (NamePrimTyCon tcp) k + tc = TyConBound u k + in TCon tc diff --git a/DDC/Core/Flow/Procedure.hs b/DDC/Core/Flow/Procedure.hs --- a/DDC/Core/Flow/Procedure.hs +++ b/DDC/Core/Flow/Procedure.hs @@ -15,20 +15,14 @@ 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 } - + , procedureParamFlags :: [(Bool,BindF)] + , procedureNest :: Nest } -- | A loop nest. data Nest @@ -37,20 +31,31 @@ | NestList { nestList :: [Nest]} + -- Used to define the outer loop of a process. | NestLoop { nestRate :: Type Name , nestStart :: [StmtStart] , nestBody :: [StmtBody] , nestInner :: Nest - , nestEnd :: [StmtEnd] - , nestResult :: Exp () Name } + , nestEnd :: [StmtEnd] } - | NestIf + -- Guarded context, + -- used when lowering pack-like operations. + | NestGuard { nestOuterRate :: Type Name , nestInnerRate :: Type Name , nestFlags :: Bound Name , nestBody :: [StmtBody] , nestInner :: Nest } + + -- Segmented context, + -- used when lowering segmented operations. + | NestSegment + { nestOuterRate :: Type Name + , nestInnerRate :: Type Name + , nestLength :: Bound Name + , nestBody :: [StmtBody] + , nestInner :: Nest } deriving Show @@ -70,13 +75,18 @@ -- | Statements that can appear at the start of a loop. -- These initialise accumulators. data StmtStart - -- Allocate a new vector. - = StartVecNew + -- | Evaluate a pure expression + = StartStmt + { startResultBind :: Bind Name + , startExpression :: Exp () Name } + + -- | Allocate a new vector. + | StartVecNew { startVecNewName :: Name , startVecNewElemType :: Type Name , startVecNewRate :: Type Name } - -- Inititlise a new accumulator. + -- | Inititlise a new accumulator. | StartAcc { startAccName :: Name , startAccType :: Type Name @@ -140,8 +150,7 @@ -- | Statements that appear after a loop to cleanup. data StmtEnd - -- | Pure ending statements to produce the result of - -- the overall process. + -- | Generic ending statements. = EndStmt { endBind :: Bind Name , endExp :: Exp () Name } @@ -152,10 +161,9 @@ , endType :: Type Name , endAccName :: Name } - -- | Destructively slice down a vector to its final size. - | EndVecSlice + -- | Destructively truncate a vector to its final size. + | EndVecTrunc { endVecName :: Name , endVecType :: Type Name - , endVecRate :: Type Name } + , endVecAcc :: Bound Name } deriving Show - diff --git a/DDC/Core/Flow/Process.hs b/DDC/Core/Flow/Process.hs --- a/DDC/Core/Flow/Process.hs +++ b/DDC/Core/Flow/Process.hs @@ -1,6 +1,7 @@ module DDC.Core.Flow.Process ( Process (..) + , Operator (..)) where import DDC.Core.Flow.Process.Process diff --git a/DDC/Core/Flow/Process/Operator.hs b/DDC/Core/Flow/Process/Operator.hs --- a/DDC/Core/Flow/Process/Operator.hs +++ b/DDC/Core/Flow/Process/Operator.hs @@ -1,6 +1,7 @@ module DDC.Core.Flow.Process.Operator - (Operator (..)) + ( Operator (..) + , bindOfOp) where import DDC.Core.Flow.Exp @@ -29,95 +30,264 @@ } ----------------------------------------- - -- | Convert a series to a manifest vector. - | OpCreate - { -- | Binder for result vector - opResultVector :: BindF + -- | Flat replicate. + | OpRep + { -- Binder for result series. + opResultSeries :: BindF - -- | Rate of input series - , opInputRate :: TypeF + -- Rate of output series. + , opOutputRate :: TypeF - -- | Bound of input series. - , opInputSeries :: BoundF + -- Type of the elements. + , opElemType :: TypeF - -- | Rate that should be used when allocating the vector. - -- This is filled in by `patchAllocRates`. - , opAllocRate :: Maybe TypeF + -- Exp to compute the element to be replicated. + , opInputExp :: ExpF } - -- | Type of the elements. + ----------------------------------------- + -- | Segmented replicate. + | OpReps + { -- Binder for result series. + opResultSeries :: BindF + + -- Rate of input series. + , opInputRate :: TypeF + + -- Rate of output series. + , opOutputRate :: TypeF + + -- Type of the elements. , opElemType :: TypeF + + -- Bound for the segment descriptor. + , opSegdBound :: BoundF + + -- Bound for the input series. + , opInputSeries :: BoundF } + + ----------------------------------------- + -- | Segmented indices. + | OpIndices + { -- Binder for result series. + opResultSeries :: BindF + + -- Rate of input series. + , opInputRate :: TypeF + + -- Rate of output series. + , opOutputRate :: TypeF + + -- Bound for the segment descriptor. + , opSegdBound :: BoundF } + + ----------------------------------------- + -- | Fill a vector with elements from a series. + | OpFill + { -- Binder for result value (a Unit) + opResultBind :: BindF + + -- Bound of target vector. + , opTargetVector :: BoundF + + -- Rate of input series. + , opInputRate :: TypeF + + -- Bound of input series. + , opInputSeries :: BoundF + + -- Type of the elements. + , opElemType :: TypeF } + + ----------------------------------------- + -- | Gather elements from a vector into a series. + | OpGather + { -- Binder for result series. + opResultBind :: BindF + + -- Bound of source elem vector. + , opSourceVector :: BoundF + + -- Bound of source index series. + , opSourceIndices :: BoundF + + -- Rate of input and output series. + , opInputRate :: TypeF + + -- Rate of input vector series. + , opVectorRate :: TypeF + + -- Type of gathered elements. + , opElemType :: TypeF } + ----------------------------------------- + -- | Scatter elements from a series into a vector. + | OpScatter + { -- Binder for result value (a Unit) + opResultBind :: BindF + -- Bound of target vector. + , opTargetVector :: BoundF + + -- Bound of source index series. + , opSourceIndices :: BoundF + + -- Bound of source element series. + , opSourceElems :: BoundF + + -- Rate of input serieses. + , opInputRate :: TypeF + + -- Type of elements. + , opElemType :: TypeF + } + ----------------------------------------- -- | Apply a function to corresponding elements in several input series -- of the same rate, producing a new series. This subsumes the regular -- 'map' operator as well as 'zipWith' like operators where the input -- lengths are identical. | OpMap - { -- | Arity of map, number of input streams. + { -- Arity of map, number of input streams. opArity :: Int - -- | Binder for result series. + -- Binder for result series. , opResultSeries :: BindF - -- | Rate of all input series. + -- Rate of all input series. , opInputRate :: TypeF - -- | Names for input series. + -- Names for input series. , opInputSeriess :: [BoundF] - -- | Worker input parameters + -- Worker input parameters , opWorkerParams :: [BindF] - -- | Worker body + -- Worker body , opWorkerBody :: ExpF } ----------------------------------------- - -- | Fold all the elements of a series. - | OpFold - { -- | Binder for result value. - opResultValue :: BindF + -- | Pack a series according to a selector. + | OpPack + { -- Binder for result series. + opResultSeries :: BindF - -- | Rate of input series. + -- Rate of input series. , opInputRate :: TypeF - -- | Bound of input series. + -- Bound of input series. , opInputSeries :: BoundF - -- | Starting accumulator value. - , opZero :: ExpF + -- Rate of output series. + , opOutputRate :: TypeF - -- | Worker parameter for index input. - -- Should be BNone for OpFlowFold, but something for OpFlowFoldIndex + -- Type of a series element. + , opElemType :: TypeF } + + ----------------------------------------- + -- | Generate a new Series, with elements based on index + | OpGenerate + { -- Binder for result series. + opResultSeries :: BindF + + -- Rate of output series. + , opOutputRate :: TypeF + + -- Worker parameter for function index input. , opWorkerParamIndex :: BindF - -- | Worker parameter for accumulator input. + -- Worker body. + , opWorkerBody :: ExpF + } + + ----------------------------------------- + -- | Reduce the elements of a series into a reference. + | OpReduce + { -- Binder for result value (a Unit) + opResultBind :: BindF + + -- Bound of target Ref. + , opTargetRef :: BoundF + + -- Rate of input series. + , opInputRate :: TypeF + + -- Bound of input series. + , opInputSeries :: BoundF + + -- Neutral element. + , opZero :: ExpF + + -- Worker parameter for accumulator input. , opWorkerParamAcc :: BindF - -- | Worker parameter for element input. + -- Worker parameter for element input. , opWorkerParamElem :: BindF - -- | Worker body. - , opWorkerBody :: ExpF } + -- Worker body. + , opWorkerBody :: ExpF + } ----------------------------------------- - -- | Pack a series according to a selector. - | OpPack - { -- | Binder for result series. + -- | Convert a series from a vector + | OpSeriesOfRateVec + { -- Binder for result series. opResultSeries :: BindF - -- | Rate of input series. + -- Rate of the input series. , opInputRate :: TypeF - -- | Bound of input series. - , opInputSeries :: BoundF + -- Bound of the input vector + , opInputRateVec :: BoundF - -- | Rate of output series. - , opOutputRate :: TypeF + -- Type of the elements. + , opElemType :: TypeF + } - -- | Type of a series element. - , opElemType :: TypeF } - deriving Show + ----------------------------------------- + -- | Use an existing series passed in as argument + | OpSeriesOfArgument + { -- Binder for result series. + opResultSeries :: BindF + -- Rate of the input series. + , opInputRate :: TypeF + + -- Type of the elements. + , opElemType :: TypeF + } + + + deriving (Show, Eq) + +bindOfOp :: Operator -> BindF +bindOfOp o + = case o of + OpId{} + -> opResultSeries o + OpRep{} + -> opResultSeries o + OpReps{} + -> opResultSeries o + OpIndices{} + -> opResultSeries o + OpMap{} + -> opResultSeries o + OpPack{} + -> opResultSeries o + OpGenerate{} + -> opResultSeries o + OpSeriesOfRateVec{} + -> opResultSeries o + OpSeriesOfArgument{} + -> opResultSeries o + + OpFill{} + -> opResultBind o + OpGather{} + -> opResultBind o + OpScatter{} + -> opResultBind o + OpReduce{} + -> opResultBind o diff --git a/DDC/Core/Flow/Process/Pretty.hs b/DDC/Core/Flow/Process/Pretty.hs --- a/DDC/Core/Flow/Process/Pretty.hs +++ b/DDC/Core/Flow/Process/Pretty.hs @@ -2,46 +2,142 @@ 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 () +import DDC.Core.Flow.Context +import DDC.Core.Pretty () +import DDC.Data.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) + , text " parameters: " <> ppr (processParamFlags p) + , indent 2 $ ppr $ processContext p ] +instance Pretty Context where + ppr cc + = case cc of + ContextRate{} + -> vcat + $ [ text "Rate " <> ppr (contextRate cc) ] + ++ ops + ++ inner + ContextSelect{} + -> vcat + $ [ text "Select " <> ppr (contextInnerRate cc) <> text " <= " <> ppr (contextOuterRate cc) + , text " flags: " <> ppr (contextFlags cc) + , text " sel: " <> ppr (contextSelector cc) ] + ++ ops + ++ inner + ContextSegment{} + -> vcat + $ [ text "Segment " <> ppr (contextInnerRate cc) <> text " <= " <> ppr (contextOuterRate cc) + , text " lens: " <> ppr (contextLens cc) + , text " segd: " <> ppr (contextSegd cc) ] + ++ ops + ++ inner + ContextAppend{} + -> vcat + $ [ text "Append " <> ppr (contextRate1 cc) <> text " " <> ppr (contextRate2 cc) + , indent 2 $ ppr $ contextInner1 cc + , indent 2 $ ppr $ contextInner2 cc ] + + where + ops = map (indent 2 . ppr) (contextOps cc) + inner = map (indent 2 . ppr) (contextInner cc) + + 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) ] + , text " rate: " <> ppr (opInputRate op) + , text " input: " <> ppr (opInputSeries op) + , text " result: " <> ppr (opResultSeries op) ] - ppr op@OpCreate{} + ppr op@OpRep{} = vcat - [ text "Create" - , text " rate: " <> ppr (opInputRate op) - , text " input: " <> ppr (opInputSeries op) - , text " result: " <> ppr (opResultVector op) ] + [ text "Rep" + , text " result: " <> ppr (opResultSeries op) + , text " output rate: " <> ppr (opOutputRate op) + , text " type: " <> ppr (opElemType op) ] - ppr op@OpMap{} + ppr op@OpReps{} = vcat - [ text "Map" - , text " rate: " <> ppr (opInputRate op) ] + [ text "Reps" + , text " result: " <> ppr (opResultSeries op) + , text " input rate: " <> ppr (opInputRate op) + , text " output rate: " <> ppr (opOutputRate op) + , text " type: " <> ppr (opElemType op) + , text " segd: " <> ppr (opSegdBound op) + , text " input: " <> ppr (opInputSeries op) ] + + ppr op@OpIndices{} + = vcat + [ text "Indices" + , text " result: " <> ppr (opResultSeries op) + , text " input rate: " <> ppr (opInputRate op) + , text " output rate: " <> ppr (opOutputRate op) ] - ppr op@OpFold{} + ppr op@OpFill{} = vcat - [ text "Fold" - , text " rate: " <> ppr (opInputRate op) ] + [ text "Fill" + , text " target: " <> ppr (opTargetVector op) + , text " input: " <> ppr (opInputSeries op) ] + ppr op@OpGather{} + = vcat + [ text "Gather" + , text " result: " <> ppr (opResultBind op) + , text " vector: " <> ppr (opSourceVector op) + , text " indices: " <> ppr (opSourceIndices op) + , text " rate: " <> ppr (opInputRate op) + , text " type: " <> ppr (opElemType op) ] + + ppr op@OpScatter{} + = vcat + [ text "Scatter" + , text " vector: " <> ppr (opTargetVector op) + , text " indices: " <> ppr (opSourceIndices op) + , text " elems: " <> ppr (opSourceElems op) + , text " rate: " <> ppr (opInputRate op) + , text " type: " <> ppr (opElemType op) ] + + ppr op@OpGenerate{} + = vcat + [ text "Generate" + , text " rate: " <> ppr (opOutputRate op) ] + + ppr op@OpReduce{} + = vcat + [ text "Reduce" + , text " rate: " <> ppr (opInputRate op) + , text " input: " <> ppr (opInputSeries op) ] + + ppr op@OpMap{} + = vcat + [ text "Map" + , text " rate: " <> ppr (opInputRate op) + , text " result: " <> ppr (opResultSeries op) ] + ppr op@OpPack{} = vcat [ text "Pack" - , text " input rate: " <> ppr (opInputRate op) - , text " output rate: " <> ppr (opOutputRate op) ] + , text " input rate: " <> ppr (opInputRate op) + , text " output rate: " <> ppr (opOutputRate op) ] + + ppr op@OpSeriesOfRateVec{} + = vcat + [ text "SeriesOfRateVec" + , text " rate: " <> ppr (opInputRate op) + , text " input: " <> ppr (opInputRateVec op) + , text " result: " <> ppr (opResultSeries op) ] + + ppr op@OpSeriesOfArgument{} + = vcat + [ text "SeriesOfArgument" + , text " rate: " <> ppr (opInputRate op) + , text " result: " <> ppr (opResultSeries op) ] + + diff --git a/DDC/Core/Flow/Process/Process.hs b/DDC/Core/Flow/Process/Process.hs --- a/DDC/Core/Flow/Process/Process.hs +++ b/DDC/Core/Flow/Process/Process.hs @@ -1,18 +1,14 @@ module DDC.Core.Flow.Process.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. +-- | A process is a graph of series operators that read from some parameter +-- series and write to some accumulators. data Process = Process { -- | Name of whole process. @@ -20,36 +16,20 @@ -- source code. processName :: Name - -- | Type parameters to process. - -- These are the type parameters of the original function. - , processParamTypes :: [BindF] + -- | Proc type + , processProcType :: TypeF - -- | Value parameters to process. - -- These are the value parameters of the original function. - , processParamValues :: [BindF] + -- | Rate of process loop + , processLoopRate :: TypeF - -- | Flow contexts in this process. + -- | Parameters to process. + -- These are the parameters of the original function, with flag being true for types. + , processParamFlags :: [(Bool, BindF)] + + -- | Flow context 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 + , processContext :: Context } diff --git a/DDC/Core/Flow/Profile.hs b/DDC/Core/Flow/Profile.hs --- a/DDC/Core/Flow/Profile.hs +++ b/DDC/Core/Flow/Profile.hs @@ -12,7 +12,7 @@ import DDC.Core.Fragment import DDC.Core.Lexer import DDC.Type.Exp -import DDC.Data.Token +import DDC.Data.SourcePos import Control.Monad.State.Strict import DDC.Type.Env (Env) import qualified DDC.Type.Env as Env @@ -25,15 +25,27 @@ { profileName = "Flow" , profileFeatures = features , profilePrimDataDefs = primDataDefs - , profilePrimSupers = primSortEnv , profilePrimKinds = primKindEnv , profilePrimTypes = primTypeEnv + , profileTypeIsUnboxed = const False + , profileNameIsHole = Nothing + , profileMakeLiteralName = Just makeLiteralName } - -- We don't need to distinguish been boxed and unboxed - -- because we allow unboxed instantiation. - , profileTypeIsUnboxed = const False } +-- | Convert a literal to a Salt name. +makeLiteralName :: SourcePos -> Literal -> Bool -> Maybe Name +makeLiteralName _ lit True + = case lit of + LNat n -> Just $ NameLitNat n + LInt i -> Just $ NameLitInt i + LWord i b -> Just $ NameLitWord i b + LFloat f b -> Just $ NameLitFloat (toRational f) b + _ -> Nothing +makeLiteralName _ _ _ + = Nothing + + features :: Features features = Features @@ -41,10 +53,14 @@ , featuresTrackedClosures = False , featuresFunctionalEffects = False , featuresFunctionalClosures = False + , featuresEffectCapabilities = False + , featuresImplicitRun = False + , featuresImplicitBox = False , featuresPartialPrims = True , featuresPartialApplication = True , featuresGeneralApplication = True , featuresNestedFunctions = True + , featuresGeneralLetRec = False , featuresDebruijnBinders = True , featuresUnboundLevel0Vars = False , featuresUnboxedInstantiation = True @@ -56,25 +72,27 @@ -- | 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 :: String -> Int -> String -> [Located (Token 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 + where + rn (Located sp strTok) + = case renameToken readName strTok of + Just t' -> Located sp t' + Nothing -> Located sp (KErrorJunk "lexical error") -- | 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 :: String -> Int -> String -> [Located (Token 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 + where + rn (Located sp strTok) + = case renameToken readName strTok of + Just t' -> Located sp t' + Nothing -> Located sp (KErrorJunk "lexical error") -- | Create a new type variable name that is not in the given environment. diff --git a/DDC/Core/Flow/Transform/Annotate.hs b/DDC/Core/Flow/Transform/Annotate.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Annotate.hs @@ -0,0 +1,88 @@ + +module DDC.Core.Flow.Transform.Annotate + (Annotate (..)) +where +import qualified DDC.Core.Exp.Annot as A +import qualified DDC.Core.Flow.Exp.Simple.Exp as S + + +-- | Convert the `Simple` version of the AST to the `Annot` version, +-- using a the provided default annotation value. +class Annotate + (c1 :: * -> * -> *) + (c2 :: * -> * -> *) | c1 -> c2 + where + annotate :: a -> c1 a n -> c2 a n + + +instance Annotate S.Exp A.Exp where + annotate def xx + = let down = annotate def + in case xx of + S.XAnnot _ (S.XAnnot a x) -> down (S.XAnnot a x) + S.XAnnot a (S.XVar u) -> A.XVar a u + S.XAnnot a (S.XCon dc) -> A.XCon a dc + S.XAnnot a (S.XLAM b x) -> A.XLAM a b (down x) + S.XAnnot a (S.XLam b x) -> A.XLam a b (down x) + S.XAnnot a (S.XApp x1 x2) -> A.XApp a (down x1) (down x2) + S.XAnnot a (S.XLet lts x) -> A.XLet a (down lts) (down x) + S.XAnnot a (S.XCase x alts) -> A.XCase a (down x) (map down alts) + S.XAnnot a (S.XCast c x) -> A.XCast a (down c) (down x) + S.XAnnot a (S.XType t) -> A.XType a t + S.XAnnot a (S.XWitness w) -> A.XWitness a (down w) + + S.XVar u -> A.XVar def u + S.XCon dc -> A.XCon def dc + S.XLAM b x -> A.XLAM def b (down x) + S.XLam b x -> A.XLam def b (down x) + S.XApp x1 x2 -> A.XApp def (down x1) (down x2) + S.XLet lts x -> A.XLet def (down lts) (down x) + S.XCase x alts -> A.XCase def (down x) (map down alts) + S.XCast c x -> A.XCast def (down c) (down x) + S.XType t -> A.XType def t + S.XWitness w -> A.XWitness def (down w) + + +instance Annotate S.Cast A.Cast where + annotate def cc + = let down = annotate def + in case cc of + S.CastWeakenEffect eff -> A.CastWeakenEffect eff + S.CastPurify w -> A.CastPurify (down w) + S.CastBox -> A.CastBox + S.CastRun -> A.CastRun + + +instance Annotate S.Lets A.Lets where + annotate def lts + = let down = annotate def + in case lts of + S.LLet b x -> A.LLet b (down x) + S.LRec bxs -> A.LRec [(b, down x) | (b, x) <- bxs] + S.LPrivate bks mT bts -> A.LPrivate bks mT bts + + +instance Annotate S.Alt A.Alt where + annotate def alt + = let down = annotate def + in case alt of + S.AAlt S.PDefault x -> A.AAlt A.PDefault (down x) + S.AAlt (S.PData dc bs) x -> A.AAlt (A.PData dc bs) (down x) + + +instance Annotate S.Witness A.Witness where + annotate def wit + = let down = annotate def + in case wit of + S.WAnnot _ (S.WAnnot a x) -> down (S.WAnnot a x) + S.WAnnot a (S.WVar u) -> A.WVar a u + S.WAnnot a (S.WCon wc) -> A.WCon a wc + S.WAnnot a (S.WApp w1 w2) -> A.WApp a (down w1) (down w2) + S.WAnnot a (S.WType t) -> A.WType a t + + S.WVar u -> A.WVar def u + S.WCon dc -> A.WCon def dc + S.WApp x1 x2 -> A.WApp def (down x1) (down x2) + S.WType t -> A.WType def t + + diff --git a/DDC/Core/Flow/Transform/Concretize.hs b/DDC/Core/Flow/Transform/Concretize.hs --- a/DDC/Core/Flow/Transform/Concretize.hs +++ b/DDC/Core/Flow/Transform/Concretize.hs @@ -6,8 +6,9 @@ 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 DDC.Core.Flow.Transform.TransformUpX +import DDC.Core.Env.EnvX (EnvX) +import qualified DDC.Core.Env.EnvX as EnvX import qualified Data.Map as Map @@ -15,70 +16,111 @@ -- use value level ones. concretizeModule :: Module () Name -> Module () Name concretizeModule mm - = transformSimpleUpX concretizeX Env.empty Env.empty mm + = transformSimpleUpX concretizeX EnvX.empty mm -- | Rewrite an expression to use concrete operators. concretizeX - :: KindEnvF -> TypeEnvF + :: EnvX Name -> ExpF -> Maybe ExpF -concretizeX _kenv tenv xx +concretizeX env xx -- loop# -> loopn# - | Just ( NameOpLoop OpLoopLoop + -- using an existing RateNat in the environment. + | Just ( NameOpControl OpControlLoop , [XType tK, xF]) <- takeXPrimApps xx - , Just (nS, _, tA) <- findSeriesWithRate tenv tK - , xS <- XVar (UName nS) + , Just nRN <- findRateNatWithRate env tK + , xRN <- XVar (UName nRN) + = Just + $ xLoopN tK xRN xF + + -- loop# -> loopn# + -- using the length of a series to get the rate. + | Just ( NameOpControl OpControlLoop + , [XType tK, xF]) <- takeXPrimApps xx + , Just (nS, tP, _, tA) <- findSeriesWithRate env tK + , xS <- XVar (UName nS) = Just - $ xLoopLoopN + $ xLoopN tK -- type level rate - (xRateOfSeries tK tA xS) -- + (xRateOfSeries tP tK tA xS) -- xF -- loop body - -- newVectorR# -> newVectorN# + -- newVectorR# -> newVector# | Just ( NameOpStore OpStoreNewVectorR , [XType tA, XType tK]) <- takeXPrimApps xx - , Just (nS, _, tS) <- findSeriesWithRate tenv tK - , xS <- XVar (UName nS) + , Just (nS, tP, _, tS) <- findSeriesWithRate env tK + , xS <- XVar (UName nS) = Just - $ xNewVectorN - tA tK - (xRateOfSeries tK tS xS) + $ xNewVector + tA + (xNatOfRateNat tK $ xRateOfSeries tP tK tS xS) | otherwise = Nothing --- | Search the given environment for the name of a series with the +------------------------------------------------------------------------------- +-- | Search the given environment for the name of a RateNat with the -- given rate parameter. We only look at named binders. +findRateNatWithRate + :: EnvX Name -- ^ Type Environment. + -> Type Name -- ^ Rate type. + -> Maybe Name + -- ^ RateNat name +findRateNatWithRate env tR + = go (Map.toList (EnvX.envxMap env)) + where go [] = Nothing + go ((n, tRN) : moar) + | isRateNatTypeOfRate tR tRN = Just n + | otherwise = go moar + + +-- | Check whether some type is a RateNat type of the given rate. +isRateNatTypeOfRate + :: Type Name -> Type Name + -> Bool + +isRateNatTypeOfRate tR tRN + | Just ( NameTyConFlow TyConFlowRateNat + , [tR']) <- takePrimTyConApps tRN + , tR == tR' + = True + + | otherwise + = False + + +------------------------------------------------------------------------------- +-- | Search the given environment for the name of a series with the +-- given result rate parameter. We only look at named binders. findSeriesWithRate - :: TypeEnvF -- ^ Type Environment. + :: EnvX Name -- ^ 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 + -> Maybe (Name, Type Name, Type Name, Type Name) + -- ^ Series name, process, result rate, element type. +findSeriesWithRate env tK + = go (Map.toList (EnvX.envxMap env)) + where go [] = Nothing go ((n, tS) : moar) - = case isSeriesTypeOfRate tR tS of - Nothing -> go moar - Just (_, tA) -> Just (n, tR, tA) + = case isSeriesTypeOfRate tK tS of + Nothing -> go moar + Just (tP, _, tA) -> Just (n, tP, tK, 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`. +-- is of the given result rate. If it is then return the process, result rate, +-- loop rate and element types, otherwise `Nothing`. isSeriesTypeOfRate :: Type Name -> Type Name - -> Maybe (Type Name, Type Name) + -> Maybe (Type Name, Type Name, Type Name) -isSeriesTypeOfRate tR tS +isSeriesTypeOfRate tK tS | Just ( NameTyConFlow TyConFlowSeries - , [tR', tA]) <- takePrimTyConApps tS - , tR == tR' - = Just (tR, tA) + , [tP, tK', tA]) <- takePrimTyConApps tS + , tK == tK' + = Just (tP, tK, tA) | otherwise = Nothing diff --git a/DDC/Core/Flow/Transform/Deannotate.hs b/DDC/Core/Flow/Transform/Deannotate.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Deannotate.hs @@ -0,0 +1,74 @@ + +module DDC.Core.Flow.Transform.Deannotate + (Deannotate(..)) +where +import qualified DDC.Core.Exp.Annot as A +import qualified DDC.Core.Flow.Exp.Simple.Exp as S + + +-- | Convert the `Annot` version of the AST to the `Simple` version, +-- using the provided function to decide when to keep the annotation. +class Deannotate + (c1 :: * -> * -> *) + (c2 :: * -> * -> *) | c1 -> c2 + where + deannotate :: (a -> Maybe a) -> c1 a n -> c2 a n + + +instance Deannotate A.Exp S.Exp where + deannotate f xx + = let down = deannotate f + wrap a x = case f a of + Nothing -> x + Just a' -> S.XAnnot a' x + in case xx of + A.XVar a u -> wrap a (S.XVar u) + A.XCon a dc -> wrap a (S.XCon dc) + A.XLAM a b x -> wrap a (S.XLAM b (down x)) + A.XLam a b x -> wrap a (S.XLam b (down x)) + A.XApp a x1 x2 -> wrap a (S.XApp (down x1) (down x2)) + A.XLet a lts x2 -> wrap a (S.XLet (down lts) (down x2)) + A.XCase a x alts -> wrap a (S.XCase (down x) (map down alts)) + A.XCast a cc x -> wrap a (S.XCast (down cc) (down x)) + A.XType a t -> wrap a (S.XType t) + A.XWitness a w -> wrap a (S.XWitness (down w)) + + +instance Deannotate A.Lets S.Lets where + deannotate f lts + = let down = deannotate f + in case lts of + A.LLet b x -> S.LLet b (down x) + A.LRec bxs -> S.LRec [(b, down x) | (b, x) <- bxs] + A.LPrivate bks mt bts -> S.LPrivate bks mt bts + + +instance Deannotate A.Alt S.Alt where + deannotate f aa + = case aa of + A.AAlt A.PDefault x -> S.AAlt S.PDefault (deannotate f x) + A.AAlt (A.PData dc bs) x -> S.AAlt (S.PData dc bs) (deannotate f x) + + +instance Deannotate A.Witness S.Witness where + deannotate f ww + = let down = deannotate f + wrap a x = case f a of + Nothing -> x + Just a' -> S.WAnnot a' x + in case ww of + A.WVar a u -> wrap a (S.WVar u) + A.WCon a wc -> wrap a (S.WCon wc) + A.WApp a w1 w2 -> wrap a (S.WApp (down w1) (down w2)) + A.WType a t -> wrap a (S.WType t) + + +instance Deannotate A.Cast S.Cast where + deannotate f cc + = let down = deannotate f + in case cc of + A.CastWeakenEffect e -> S.CastWeakenEffect e + A.CastPurify w -> S.CastPurify (down w) + A.CastBox -> S.CastBox + A.CastRun -> S.CastRun + diff --git a/DDC/Core/Flow/Transform/Extract.hs b/DDC/Core/Flow/Transform/Extract.hs --- a/DDC/Core/Flow/Transform/Extract.hs +++ b/DDC/Core/Flow/Transform/Extract.hs @@ -1,13 +1,14 @@ module DDC.Core.Flow.Transform.Extract - (extractModule) + ( extractModule + , extractProcedure) where -import DDC.Core.Flow.Transform.Extract.Intersperse import DDC.Core.Flow.Compounds import DDC.Core.Flow.Procedure import DDC.Core.Flow.Prim +import DDC.Core.Flow.Prim.OpStore import DDC.Core.Flow.Exp -import DDC.Core.Transform.Annotate +import DDC.Core.Flow.Transform.Annotate import DDC.Core.Module @@ -27,43 +28,56 @@ -- | 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 ) +extractProcedure (Procedure n params nest) + = let + tyOfFlags (True, b) rest + = TForall b rest + tyOfFlags (False, b) rest + = tFun (typeOfBind b) rest + tBody = foldr tyOfFlags tUnit $ params + in ( BName n tBody + , makeXLamFlags params + $ xLets (concatMap vecBuffers $ map snd $ filter (not.fst) params) + $ extractNest nest xUnit ) +vecBuffers + :: BindF + -> [LetsF] +vecBuffers (BName n t) + | isVectorType t + , Just (_, [t']) <- takePrimTyConApps t + = [ LLet (BName (NameVarMod n "buf") (tBuffer t')) + (xBufOfVector t' $ XVar $ UName n) ] + +vecBuffers _ + = [] + ------------------------------------------------------------------------------- -- | Extract code for a loop nest. extractNest :: Nest -- ^ Loops to run in sequence. - -> [LetsF] -- ^ Baseband statements from the source program - -- that run after the loop operators. -> ExpF -- ^ Final result of procedure. -> ExpF -extractNest nest stmts xResult - = let stmts' = intersperseStmts (extractLoop nest) stmts - in xLets stmts' xResult +extractNest nest xResult + = xLets (extractLoop nest) xResult ------------------------------------------------------------------------------- -- | Extract code for a possibly nested loop. extractLoop :: Nest -> [LetsF] --- Code in a loop context. -extractLoop (NestLoop tRate starts bodys inner ends _result) +-- Code in the top-level loop context. +extractLoop (NestLoop tRate starts bodys inner ends) = let -- Starting statements. lsStart = concatMap extractStmtStart starts -- The loop itself. lLoop = LLet (BNone tUnit) - (xApps (XVar (UPrim (NameOpLoop OpLoopLoop) - (typeOpLoop OpLoopLoop))) + (xApps (XVar (UPrim (NameOpControl OpControlLoop) + (typeOpControl OpControlLoop))) [ XType tRate -- loop rate , xBody ]) -- loop body @@ -83,31 +97,47 @@ in lsStart ++ [lLoop] ++ lsEnd --- Code in a select / if context. -extractLoop (NestIf _tRateOuter tRateInner uFlags stmtsBody nested) +-- Code in a guard context. +extractLoop (NestGuard _tRateOuter _tRateInner uFlags stmtsBody nested) = let -- Get the name of a single flag from the series of flags. UName nFlags = uFlags nFlag = NameVarMod nFlags "elem" xFlag = XVar (UName nFlag) - -- Make a name for the counter. - TVar (UName nK) = tRateInner - uCounter = UName (NameVarMod nK "count") - - xGuard = xLoopGuard xFlag (XVar uCounter) - ( XLam (BAnon tNat) + xBody = xGuard xFlag + ( XLam (BNone tUnit) $ xLets (lsBody ++ lsNested) xUnit) - -- Selector context. - lsBody = concatMap extractStmtBody stmtsBody + -- Statements in the guard context. + lsBody = concatMap extractStmtBody stmtsBody -- Nested contexts. - lsNested = extractLoop nested + lsNested = extractLoop nested - in [LLet (BNone tUnit) xGuard] + in [LLet (BNone tUnit) xBody] +-- Code in a segment context. +extractLoop (NestSegment _tRateOuter _tRateInner uLengths stmtsBody nested) + = let + -- Get the name of a single segment length from the series of lengths. + UName nLengths = uLengths + nLength = NameVarMod nLengths "elem" + xLength = XVar (UName nLength) + xBody = xSegment xLength + ( XLam (BAnon tNat) -- Index into current segment. + $ xLets (lsBody ++ lsNested) xUnit) + + -- Statements in the segment context. + lsBody = concatMap extractStmtBody stmtsBody + + -- Nested contexts. + lsNested = extractLoop nested + + in [LLet (BNone tUnit) xBody] + + extractLoop NestEmpty = [] @@ -121,7 +151,11 @@ extractStmtStart :: StmtStart -> [LetsF] extractStmtStart ss = case ss of - -- Allocate a new vector + -- Evaluate a pure expression. + StartStmt b x + -> [LLet b x] + + -- Allocate a new vector. StartVecNew nVec tElem tRate' -> [LLet (BName nVec (tVector tElem)) (xNewVectorR tElem tRate') ] @@ -144,7 +178,7 @@ -- Write to a vector. BodyVecWrite nVec tElem xIx xVal -> [ LLet (BNone tUnit) - (xWriteVector tElem (XVar (UName nVec)) xIx xVal)] + (xWriteVector tElem (XVar (UName $ NameVarMod nVec "buf")) xIx xVal)] -- Read from an accumulator. BodyAccRead n t bVar @@ -171,19 +205,17 @@ -> [LLet (BName n t) (xRead t (XVar (UName nAcc))) ] - -- Slice. - EndVecSlice nVec tElem tRate + -- Truncate a vector down to its final size. + EndVecTrunc nVec tElem uCounter -> let -- Get the name of the counter. - TVar (UName nK) = tRate - uCounter = UName (NameVarMod nK "count") - xCounter = xRead tInt (XVar uCounter) + xCounter = xRead tNat (XVar uCounter) xVec = XVar (UName nVec) -- Read the counter in a let since it will need to be threaded - in [ LLet (BAnon tInt) + in [ LLet (BAnon tNat) xCounter - , LLet (BName nVec (tVector tElem)) - (xSliceVector tElem (XVar (UIx 0)) xVec) ] + , LLet (BNone tUnit) + (xTruncVector tElem (XVar (UIx 0)) xVec) ] diff --git a/DDC/Core/Flow/Transform/Extract/Intersperse.hs b/DDC/Core/Flow/Transform/Extract/Intersperse.hs deleted file mode 100644 --- a/DDC/Core/Flow/Transform/Extract/Intersperse.hs +++ /dev/null @@ -1,53 +0,0 @@ - -module DDC.Core.Flow.Transform.Extract.Intersperse - (intersperseStmts) -where -import DDC.Core.Flow.Compounds -import DDC.Core.Flow.Prim -import DDC.Core.Flow.Exp -import DDC.Core.Collect -import DDC.Core.Transform.Annotate -import DDC.Type.Env -import Data.List (partition, (\\)) -import qualified Data.Set as Set - - --- | Given two lists of lets, order them so that any variables are bound before use. -intersperseStmts :: [LetsF] -> [LetsF] -> [LetsF] -intersperseStmts ls rs - = let bls = nubbish $ map takeSubstBoundsOfBinds $ map valwitBindsOfLets ls - brs = nubbish $ map takeSubstBoundsOfBinds $ map valwitBindsOfLets rs - in intersperse' (ls `zip` bls ++ rs `zip` brs) - - --- Because a name might be bound a couple of times --- (see extractStmtEnd:EndVecSlice) -nubbish :: [[Bound Name]] -> [[Bound Name]] -nubbish bs' = go bs' [] - where go [] _ = [] - go (b:bs) accs = (b \\ accs) : go bs (accs ++ b) - - -intersperse' - :: [(Lets () Name, [Bound Name])] - -> [Lets () Name] - -intersperse' [] = [] - -intersperse' ((x,b):bxs) - -- Check if any of the free variables in x are bound later on. - -- If so, defer this binding... - | f <- freeXLets x - , (r:rs,os) <- partition (any (flip Set.member f) . snd) bxs - , (x', _) <- r - = x' : intersperse' (rs ++ (x, b) : os) - - -- Otherwise it's a valid binding - | otherwise - = x : intersperse' bxs - - -freeXLets :: LetsF -> Set.Set (Bound Name) -freeXLets ll - = freeX empty $ annotate () (XLet ll (XCon (dcBool True))) - diff --git a/DDC/Core/Flow/Transform/Forward.hs b/DDC/Core/Flow/Transform/Forward.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Forward.hs @@ -0,0 +1,68 @@ +module DDC.Core.Flow.Transform.Forward + ( forwardProcesses ) +where +import DDC.Core.Flow.Profile +import DDC.Core.Flow.Prim +import DDC.Core.Flow.Prim.KiConFlow +import DDC.Core.Flow.Prim.TyConFlow +import DDC.Core.Exp.Annot +import DDC.Core.Module +import qualified DDC.Core.Simplifier as C + +import qualified DDC.Core.Transform.Forward as Forward +import qualified DDC.Core.Transform.TransformModX as T + +-- | Find all top-level Process bindings, and forward all non-series operators. +-- This is a bit of a hack, because lower doesn't accept any non-series bindings. +forwardProcesses :: Module () Name -> Module () Name +forwardProcesses mm + = T.transformModLet forwardBind mm + + +-- | Forward a single process binding +forwardBind :: Bind Name -> Exp () Name -> Exp () Name +forwardBind b xx + + -- If the result type of a top-level binding is a Process, + -- we must prepare it for the lowering transform. + -- Forward everything we can, while leaving series operators at the top. + | isProcessType $ snd $ takeTFunAllArgResult $ typeOfBind b + = C.result $ Forward.forwardX profile conf_process xx + + -- Otherwise do minimal forwarding, except for pushing any rate-valued functions + -- into their runKernel#. + | otherwise + = C.result $ Forward.forwardX profile conf_nonproc xx + where + conf_process = Forward.Config isFloatable_process False + conf_nonproc = Forward.Config isFloatable_nonproc False + + -- Deny forwarding of flow primitives. + -- Force anything else that's used only once. + -- + -- For lower to work, we need to forward everything except primitives, + -- but that duplicates work. Lower should probably be changed. + isFloatable_process lts + = case lts of + LLet (BName _ _) x + | Just (n,_) <- takeXPrimApps x + -> case n of + NameOpConcrete _ -> Forward.FloatDeny + NameOpControl _ -> Forward.FloatDeny + NameOpSeries _ -> Forward.FloatDeny + NameOpStore _ -> Forward.FloatDeny + NameOpVector _ -> Forward.FloatDeny + + _ -> Forward.FloatForceUsedOnce + _ -> Forward.FloatForceUsedOnce + + + -- Forward any Process functions - they will have Rate foralls inside them. + isFloatable_nonproc lts + = case lts of + LLet _ x + | Just (lams,_) <- takeXLamFlags x + , any (\(_,bo) -> typeOfBind bo == kRate) lams + -> Forward.FloatForce + _ -> Forward.FloatAllow + diff --git a/DDC/Core/Flow/Transform/Melt.hs b/DDC/Core/Flow/Transform/Melt.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Melt.hs @@ -0,0 +1,171 @@ + +module DDC.Core.Flow.Transform.Melt + ( Info (..) + , meltModule ) +where +import DDC.Core.Flow.Prim +import DDC.Core.Flow.Exp +import DDC.Core.Flow.Compounds +import DDC.Core.Module +import DDC.Core.Flow.Transform.Annotate +import DDC.Core.Flow.Transform.Deannotate +import Control.Monad.Writer.Strict hiding (Alt(..)) +import qualified Data.Set as Set +import Data.Set (Set) + +------------------------------------------------------------------------------- +-- | Contains binders of variables that have been melted. +data Info + = Info (Set Name) + +instance Monoid Info where + mempty = Info (Set.empty) + mappend (Info s1) (Info s2) = Info (Set.union s1 s2) + + +------------------------------------------------------------------------------- +-- | Melt compound data structures in a module. +meltModule :: Module () Name -> (Module () Name, Info) +meltModule mm + = let (xBody', info) + = runWriter + $ melt + $ deannotate (const Nothing) $ moduleBody mm + + in (mm { moduleBody = annotate () xBody' }, info) + + +------------------------------------------------------------------------------- +class Melt c where + melt :: c -> Writer Info c + + +-- Exp ------------------------------------------------------------------------ +instance Melt (Exp () Name) where + + -- Melt allocations of tuple references. + -- + -- let b = new [TupleN# tA1 tA2] xInit in ... + -- + -- => let b$1 = new [tA1] (projN_1 xInit) in + -- let b$2 = new [tA2] (projN_2 xInit) in ... + -- + melt (XLet (LLet b x1) x2) + | BName nBind _t <- b + , Just ( NameOpStore OpStoreNew + , [XType tElem, xInit]) <- takeXPrimApps x1 + , Just ( NameTyConFlow (TyConFlowTuple n) + , tAs) <- takePrimTyConApps tElem + , length tAs == n + = do + let ltsNew + = [ LLet (BName (NameVarMod nBind (show i)) (tRef tA)) + $ xNew tA (xProj tAs i xInit) + | i <- [1..n] + | tA <- tAs ] + + x2' <- melt x2 + return $ xLets ltsNew x2' + + + -- Melt reads from tuple references. + -- + -- let b = read# [TupleN# tA1 tA2] xR in ... + -- + -- => let b.1 = read# [tA1] xRef$1 in + -- let b.2 = read# [tA2] xRef$2 in + -- let b = TN# [tA1] [tA2] b$1 b$2 in ... + -- + melt (XLet (LLet b x1) x2) + | BName nBind _t <- b + , Just ( NameOpStore OpStoreRead + , [XType tElem, XVar (UName nRef)]) <- takeXPrimApps x1 + , Just ( NameTyConFlow (TyConFlowTuple n) + , tsA) <- takePrimTyConApps tElem + , length tsA == n + = do + -- read all the components + let ltsRead + = [LLet (BName (NameVarMod nBind (show i)) tA) + $ xRead tA + (XVar (UName (NameVarMod nRef (show i)))) + | i <- [1..n] + | tA <- tsA ] + + -- build the result tuple + let ltOrig + = LLet b + $ xApps (XCon (dcTupleN n)) + ( [XType t | t <- tsA] + ++ [XVar (UName (NameVarMod nBind (show i))) + | i <- [1..n]]) + + -- melt the body + x2' <- melt x2 + + return $ xLets (ltsRead ++ [ltOrig]) x2' + + + -- Melt writes to tuple references. + -- + -- let _ = write# [TupleN# tA1 tA2] xR xV in ... + -- + -- => let _ = write# [tA1] xR$1 (projN_1 xV) + -- let _ = write# [tA2] xR$2 (projN_2 xV) in ... + -- + melt (XLet (LLet b x1) x2) + | BNone tB <- b + , Just ( NameOpStore OpStoreWrite + , [XType tElem, XVar (UName nRef), xV]) <- takeXPrimApps x1 + , Just ( NameTyConFlow (TyConFlowTuple n) + , tsA) <- takePrimTyConApps tElem + , length tsA == n + = do + let ltsWrite + = [ LLet (BNone tB) + $ xWrite tA + (XVar (UName (NameVarMod nRef (show i)))) + (xProj tsA i xV) + | i <- [1..n] + | tA <- tsA ] + + x2' <- melt x2 + return $ xLets ltsWrite x2' + + + -- Boilerplate + melt xx + = case xx of + XAnnot a x -> liftM (XAnnot a) (melt x) + XLet lts x -> liftM2 XLet (melt lts) (melt x) + XApp x1 x2 -> liftM2 XApp (melt x1) (melt x2) + XVar u -> return $ XVar u + XCon dc -> return $ XCon dc + XLAM b x -> liftM (XLAM b) (melt x) + XLam b x -> liftM (XLam b) (melt x) + XCase x alts -> liftM2 XCase (melt x) (mapM melt alts) + XCast c x -> liftM (XCast c) (melt x) + XType t -> return $ XType t + XWitness w -> return $ XWitness w + + +-- Lets ----------------------------------------------------------------------- +instance Melt (Lets () Name) where + melt lts + = case lts of + LLet b x + -> liftM (LLet b) (melt x) + + LRec bxs + -> do let (bs, xs) = unzip bxs + xs' <- mapM melt xs + return $ LRec $ zip bs xs' + + LPrivate{} + -> return lts + + +-- Alt ------------------------------------------------------------------------ +instance Melt (Alt () Name) where + melt (AAlt w x) = liftM (AAlt w) (melt x) + diff --git a/DDC/Core/Flow/Transform/Prep.hs b/DDC/Core/Flow/Transform/Prep.hs deleted file mode 100644 --- a/DDC/Core/Flow/Transform/Prep.hs +++ /dev/null @@ -1,169 +0,0 @@ - -module DDC.Core.Flow.Transform.Prep - (prepModule) -where -import DDC.Core.Flow.Prim -import DDC.Core.Flow.Prim.TyConPrim -import DDC.Core.Compounds -import DDC.Core.Module -import DDC.Core.Exp -import Control.Monad.State.Strict -import Data.Map (Map) -import qualified Data.Map as Map -import DDC.Type.Env (TypeEnv) -import qualified DDC.Type.Env as Env - - --- | Prepare a module for lowering. --- We need all worker functions passed to flow operators to be eta-expanded --- and for their parameters to have real names. -prepModule - :: Module a Name - -> (Module a Name, Map Name [Type Name]) - -prepModule mm - = do runState (prepModuleM mm) Map.empty - - -prepModuleM :: Module a Name -> PrepM (Module a Name) -prepModuleM mm - = do xBody' <- prepX Env.empty $ moduleBody mm - return $ mm { moduleBody = xBody' } - - --- Do a bottom-up rewrite, --- on the way up remember names of variables that are passed as workers --- to flow operators, then eta-expand bindings with those names. --- Record the environment of let-bound expressions, to know whether to --- eta-expand in their definition or at the callsite. -prepX :: TypeEnv Name -> Exp a Name -> PrepM (Exp a Name) -prepX tenv xx - = let down = prepX tenv - in case xx of - -- MapN - XApp{} - | Just (XVar _ u, xsArgs) <- takeXApps xx - , UPrim (NameOpFlow (OpFlowMap n)) _ <- u - , _xTR : xsArgs2 <- xsArgs - , (xsA, xsArgs3) <- splitAt (n + 1) xsArgs2 - , tsA <- [t | XType t <- xsA] - , XVar _ (UName nWorker) : _ <- xsArgs3 - , Env.member (UName nWorker) tenv - -> do addWorkerArgs nWorker (take n tsA) - return xx - - -- Worker passed to map, but not let-bound. - -- Eta-expand in-place. - XApp{} - | Just (xmap@(XVar _ u), args@[_, XType tA, XType _tB, f@(XVar a _), _]) - <- takeXApps xx - , UPrim (NameOpFlow (OpFlowMap 1)) _ <- u - -> do let f' = xEtaExpand a f [tA] - args' = take 3 args ++ [f'] ++ [last args] - return $ xApps a xmap args' - - -- Detect workers passed to folds. - XApp{} - | Just (XVar _ u, [_, XType tA, XType tB, XVar _ (UName n), _, _]) - <- takeXApps xx - , UPrim (NameOpFlow OpFlowFold) _ <- u - -> do addWorkerArgs n [tA, tB] - return xx - - -- FoldIndex - XApp{} - | Just (XVar _ u, [_, XType tA, XType tB, XVar _ (UName n), _, _]) - <- takeXApps xx - , UPrim (NameOpFlow OpFlowFoldIndex) _ <- u - -> do addWorkerArgs n [tInt, tA, tB] - return xx - - -- Detect workers passed to mkSels - XApp{} - | Just (XVar _ u, [XType _tK1, XType _tA, _, XVar _ (UName n)]) - <- takeXApps xx - , UPrim (NameOpFlow (OpFlowMkSel _)) _ <- u - -> do addWorkerArgs n [] - return xx - - -- Bottom-up transform boilerplate. - XVar{} -> return xx - XCon{} -> return xx - XLAM a b x -> liftM3 XLAM (return a) (return b) (down x) - XLam a b x -> liftM3 XLam (return a) (return b) (down x) - XApp a x1 x2 -> liftM3 XApp (return a) (down x1) (down x2) - - XLet a lts x - -> do -- Slurp binds from lets, add to tenv - let tenv' = Env.extends (valwitBindsOfLets lts) tenv - x' <- prepX tenv' x - - -- Use old tenv for the binders - lts' <- prepLts tenv a lts - return $ XLet a lts' x' - - XCase a x alts -> liftM3 XCase (return a) (down x) (mapM (prepAlt tenv) alts) - XCast a c x -> liftM3 XCast (return a) (return c) (down x) - XType{} -> return xx - XWitness{} -> return xx - - --- Prepare let bindings for lowering. -prepLts :: TypeEnv Name -> a -> Lets a Name -> PrepM (Lets a Name) -prepLts tenv a lts - = case lts of - LLet b@(BName n _) x - -> do x' <- prepX tenv x - - mArgs <- lookupWorkerArgs n - case mArgs of - Just tsArgs - | length tsArgs > 0 - -> return $ LLet b $ xEtaExpand a x' tsArgs - - _ -> return $ LLet b x' - - LLet b x - -> do x' <- prepX tenv x - return $ LLet b x' - - LRec bxs - -> do let (bs, xs) = unzip bxs - let tenv' = Env.extends bs tenv - xs' <- mapM (prepX tenv') xs - return $ LRec $ zip bs xs' - - LLetRegions{} -> return lts - LWithRegion{} -> return lts - - --- Prepare case alternative for lowering. -prepAlt :: TypeEnv Name -> Alt a Name -> PrepM (Alt a Name) -prepAlt tenv (AAlt w x) - = liftM (AAlt w) (prepX tenv x) - - -xEtaExpand :: a -> Exp a Name -> [Type Name] -> Exp a Name -xEtaExpand a x tys - = xLams a (map BAnon tys) - $ xApps a x [ XVar a (UIx (length tys - 1 - ix)) - | ix <- [0 .. length tys - 1] ] - - --- State ---------------------------------------------------------------------- -type PrepS = Map Name [Type Name] -type PrepM = State PrepS - - --- | Record this name as being of a worker function. -addWorkerArgs :: Name -> [Type Name] -> PrepM () -addWorkerArgs name tsParam - = modify $ Map.insert name tsParam - - --- | Check whether this name corresponds to a worker function. -lookupWorkerArgs :: Name -> PrepM (Maybe [Type Name]) -lookupWorkerArgs name - = do names <- get - return $ Map.lookup name names - diff --git a/DDC/Core/Flow/Transform/Rates/Clusters.hs b/DDC/Core/Flow/Transform/Rates/Clusters.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Rates/Clusters.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE CPP #-} +module DDC.Core.Flow.Transform.Rates.Clusters + (cluster) + where + +#if DDC_FLOW_HAVE_LINEAR_SOLVER +import DDC.Core.Flow.Transform.Rates.Clusters.Linear + +cluster = solve_linear + +#else +import DDC.Core.Flow.Transform.Rates.Clusters.Greedy + +cluster = cluster_greedy + +#endif + diff --git a/DDC/Core/Flow/Transform/Rates/Clusters/Base.hs b/DDC/Core/Flow/Transform/Rates/Clusters/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Rates/Clusters/Base.hs @@ -0,0 +1,37 @@ +module DDC.Core.Flow.Transform.Rates.Clusters.Base where +import DDC.Core.Flow.Transform.Rates.Graph + +type TransducerMap n = n -> n -> Maybe (n,n) + +-- \forall paths p from u to v, fusion preventing \not\in p +noFusionPreventingPath :: (Ord n) => [((n,n),Bool)] -> n -> n -> Bool +noFusionPreventingPath arcs u v + -- for all paths, for all nodes in path, is fusible + = all (all snd) (paths u v) + && all (all snd) (paths v u) + where + -- list of all paths from w to x + paths w x + | w == x + = [[]] + | otherwise + = let outs = filter (\((i,_j),_f) -> i == w) arcs + in concatMap (\((w',j),f) -> map (((w',j),f):) (paths j x)) outs + + +-- | Check if two nodes may be fused based on type. +-- If they have the same type, it's fine. +-- If they have a different type, we must look for any common type transducer parents. +typeComparable :: (Ord n, Eq t) => Graph n t -> TransducerMap n -> n -> n -> Bool +typeComparable g trans a b + = case (nodeType g a, nodeType g b) of + (Just a', Just b') + -> if a' == b' + then True + else case trans a b of + Just _ -> True + Nothing -> False + _ + -> False + + diff --git a/DDC/Core/Flow/Transform/Rates/Clusters/Greedy.hs b/DDC/Core/Flow/Transform/Rates/Clusters/Greedy.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Rates/Clusters/Greedy.hs @@ -0,0 +1,126 @@ +module DDC.Core.Flow.Transform.Rates.Clusters.Greedy + (cluster_greedy) +where +import DDC.Core.Flow.Transform.Rates.Graph +import DDC.Core.Flow.Transform.Rates.Clusters.Base + +cluster_greedy + :: (Ord n, Eq t) + => Graph n t -> TransducerMap n -> [[n]] +cluster_greedy g trans + -- First find a greedy vertical clustering, then merge any leftover horizontal opportunities + -- + -- The clusters are built in reverse order, so fix them up. + = reverse + $ map reverse + $ fuse_rest vertical + where + -- Vertical fusion. + -- Go through the graph in topo order, inserting each node into a cluster + vertical + = foldl go_vertical [] + $ graphTopoOrder g + + -- Insert node n into the clusters ns + go_vertical ns n + -- Find the parent we'd like to fuse n into. It has to be a fusible edge. + = let parent = [ n' | (n',fusible) <- nodeInEdges g n, fusible] + -- The default unfused clustering to use if we can't merge n into parent + unfused = [n] : ns + in case parent of + -- There is no parent (that is fusible) + [] + -> unfused + -- Check that n and n' are the same type (can be fused). + (n':_) + | tcmp n n' + -> case insert n n' ns of + Just ns' -> ns' + Nothing -> unfused + | otherwise + -> unfused + + -- Try to insert n into the same cluster as n'. + -- If n relies on output of clusters after n' (before in cs - list is reversed), we cannot put + -- n in the n' cluster. + -- Also check that there are no fusion-preventing paths between cluster and n. + + -- We haven't seen n' yet and we're at the end, so can't put n into same cluster as n' + insert _n _n' [] + = Nothing + + insert n n' (c:cs) + -- We've reached n' cluster. + -- If there are no fusion-preventing edges between n and these nodes, we can fuse. + | n' `elem` c + = if any (not . checkPath n) c + then Nothing + else Just ((n:c) : cs) + + -- If n relies on any of these nodes and we haven't reached n', + -- we won't be able to merge n with n' + -- (because it would not be able to execute without result of these nodes) + | any (edge n) c + = Nothing + + | otherwise + = do cs' <- insert n n' cs + return (c : cs') + + + -- Do any leftover horizontal fusion that we can + fuse_rest [] = [] + fuse_rest (c:cs) + = case try_merge c cs of + Nothing + -> c : fuse_rest cs + Just cs' + -> fuse_rest cs' + + -- Nothing to merge s with + try_merge _ [] + = Nothing + + try_merge s (c:cs) + -- Can s and c be merged together? + | miscible s c + = if all (\a -> all (checkPath a) s) c + then Just ((s ++ c) : cs) + else Nothing + + -- s and c can't be merged together, but we can't move s any further back + | any (\a -> any (edge a) s) c + = Nothing + + | otherwise + = do cs' <- try_merge s cs + return (c : cs') + + + -- Helper functions + edge a b = hasEdge g (a,b) || hasEdge g (b,a) + + checkPath = noFusionPreventingPath arcs + arcs = snd $ listOfGraph g + + tcmp = typeComparable g trans + + -- Check if two clusters can be merged together + miscible s c + = let sc = s ++ c + -- For each a in c and b in s + in all (\a -> all (\b -> + -- If a and b have same type, they can be merged fine + case (nodeType g a, nodeType g b) of + (Just ta, Just tb) + -> if ta == tb + then True + -- If they have different types, but share parent transducers, + -- they can only be merged if they are merged with both parents. + else case trans a b of + Just (a',b') -> a' `elem` sc && b' `elem` sc + Nothing -> False + _ + -> False + ) s) c + diff --git a/DDC/Core/Flow/Transform/Rates/Clusters/Linear.hs b/DDC/Core/Flow/Transform/Rates/Clusters/Linear.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Rates/Clusters/Linear.hs @@ -0,0 +1,322 @@ +{-# LANGUAGE DataKinds #-} +module DDC.Core.Flow.Transform.Rates.Clusters.Linear + (solve_linear) + where + +import DDC.Data.Pretty +import DDC.Core.Flow.Transform.Rates.Graph +import DDC.Core.Flow.Transform.Rates.Clusters.Base + +import qualified Data.Map as Map + +import Numeric.Limp.Program.ResultKind +import Numeric.Limp.Program +import Numeric.Limp.Rep +import Numeric.Limp.Solvers.Cbc.Solve + +import qualified Numeric.Limp.Canon.Convert as Conv +import qualified Numeric.Limp.Canon.Simplify as CSimp + + +-- | Get parent transducers of two nodes, if exists. +-- | Integer-valued variable type for linear program +-- +-- SameCluster i j - {0,1} 0 if i and j are fused together +-- +-- C n - 0 if node is fused with all its users. Minimising this is good for array contraction. +-- +data ZVar n + = SameCluster n n + | C n + deriving (Eq, Show, Ord) + +instance Pretty n => Pretty (ZVar n) where + ppr (SameCluster a b) = text "SC" <+> ppr a <+> ppr b + ppr (C a) = text "C" <+> ppr a + + +-- | Variable type for linear program +-- Pi i - {0..} used to show the resulting partition is acyclic: +-- +-- A graph is acyclic iff there is a mapping +-- pi : Node -> Int +-- such that \forall (i,j) \in Edge +-- pi(j) > pi(i) +-- +data RVar n + = Pi n + deriving (Eq, Show, Ord) + +instance Pretty n => Pretty (RVar n) where + ppr (Pi a) = text "O" <+> ppr a + +-- | Canonical form of SameCluster variables. +-- Since we only want to generate one SameCluster variable for each pair, we generate the +-- variable with min variable then max. +mkSameCluster :: Ord n => n -> n -> ZVar n +mkSameCluster m n + = SameCluster (min m n) (max m n) + +-- | Minimise objective: +-- \Sigma_i,j Weight(i,j) * SameCluster(i,j) +gobjective :: Ord n => [n] -> [(Int,n,n)] -> Linear (ZVar n) (RVar n) IntDouble 'KZ +gobjective ns ws + = foldl (.+.) c0 + ( map (\(w,i,j) -> z (mkSameCluster i j) (Z w)) ws + ++ map (\n -> z (C n) (Z $ length ns)) ns) + + +-- | Get variable bounds - Pi are unbounded, SameCluster and C are "bools" (0 or 1) +getBounds :: Ord n => [n] -> [(Int,n,n)] -> [Bounds (ZVar n) (RVar n) IntDouble] +getBounds ns ws + = map boundC ns + ++ map boundSC ws + where + boundC n + = binary (C n) + boundSC (_,i,j) + = binary (mkSameCluster i j) + + +-- | Create constraints for edges and weights +getConstraints + :: (Ord n, Eq t) + => Int -> Graph n t + -> [((n,n),Bool)] + -> [(Int,n,n)] + -> TransducerMap n + -> Constraint (ZVar n) (RVar n) IntDouble + +getConstraints bigN g arcs ws trans + = mconcat $ map edgeConstraint arcs + ++ map weightConstraint ws + where + piDiff u v = r1 (Pi v) .-. r1 (Pi u) + sc u v = z1 (mkSameCluster u v) + + -- Edge constraints: + -- + -- For nonfusible edges (u,v), add a constraint + -- pi(v) - pi(u) >= 1 + -- which is equivalent to + -- pi(v) > pi(u) + -- or "v must be scheduled after u" + -- This will disallow u and v from being in the same cluster, as other + -- constraints require x(u,v) = 0 can only be true if pi(u) = pi(v). + -- + -- For fusible edges (u,v) + -- if they are merged together, x(u,v) = 0 and pi(v) = pi(u) + -- otherwise, x(u,v) = 1 and pi(v) > pi(u) + -- This is achieved with the constraint + -- x(u,v) <= pi(v) - pi(u) <= n * x(u,v) + -- + -- + -- Note that arcs are reversed in graph, so (v,u) below is actually an edge from u to v. + edgeConstraint ((v,u), fusible) + -- The edge must be fusible, the two nodes must have a similar size, + -- and there can be no other paths between u and v that aren't fusible. + | fusible && typeComparable g trans u v && noFusionPreventingPath arcs u v + -- We may want to remove the 'typeComparable' restriction later, and just check + -- that they have some iteration size, but not necessarily similar. + -- This would allow fusing @a@ into @c@ in @a = map...; c = cross a b@. + = let x = sc u v + in Between x (piDiff u v) (Z bigN *. x) + :&& x :<= z1 (C u) + + -- Non-fusible edge, or nodes are different types + | otherwise + -- pi(v) - pi(u) >= 1 + = piDiff u v :>= c1 + :&& z1 (C u) :== c1 + + + -- Weights between other nodes: + -- + -- For any two nodes that may be scheduled together, + -- we must make sure that if they are together, their pis *must* be the same. + -- If they are not together, their pis are unconstrained. + -- + -- -n * x(u,v) <= pi(v) - pi(u) <= n * x(u,v) + -- + -- That is, if u and v are in the same cluster (x(u,v)=0) + -- then pi(v) - pi(u) = 0, or pi(v) = pi(u) + -- + -- Otherwise, pi(v) - pi(u) has a large enough range to be practically unbounded. + -- + -- This constraint is not necessary if there is a fusible edge between the two, + -- as a more restrictive constraint will be added by edgeConstraint. + -- + weightConstraint (_,u,v) + -- If there's an edge between the two, don't bother adding this constraint + | not $ any (\((i,j),_) -> (u,v) == (i,j) || (v,u) == (i,j)) arcs + = let x = sc u v + in Between (Z (-bigN) *. x) (piDiff u v) (Z bigN *. x) + :&& checkTypes u v + + | otherwise + = CTrue + + + -- If two nodes have different types, but parent transducers with same type, + -- we may still fuse them together if their parent transducers are fused together + checkTypes u v + | Just uT <- nodeType g u + , Just vT <- nodeType g v + , uT /= vT + , Just (u',v') <- trans u v + = filtConstraint v' v u v + :&& filtConstraint u' u u v + :&& filtConstraint u' v' u v + + | otherwise + = CTrue + + -- c and d can only be fused if a and b are fused + filtConstraint a b c d + -- If a and b are the same node, they're already fused! + | a == b + = CTrue + + -- Check if it's even possible for a and b to be fused. + -- There might be a fusion-preventing edge between them. + | checkFusible a b + -- If it's possible, constrain (SC a b) <= (SC c d). + -- This means that if (SC a b) is 1 (unfused), it forces (SC c d) = 1 too. + = sc a b :<= sc c d + + -- There's a fusion-preventing path between a and b, so they can't possibly be fused. + -- So c and d won't be fused - let's just set it to 1. + | otherwise + = sc c d :== c1 + + checkFusible a b + = any (\(_, i,j) -> (i,j) == (a,b) || (i,j) == (b,a)) ws + + + + +-- | Get list of all nodes that might be clustered together, +-- and the weighted benefit of doing so. +clusterings :: (Ord n, Eq t) => [((n,n),Bool)] -> [n] -> Int -> Graph n t -> TransducerMap n -> [(Int, n,n)] +clusterings arcs ns bigN g trans + = go ns + where + -- For some node, find all later nodes of same or similar type, and calculate benefit + go (u:rest) + = [ (w,u,v) + | v <- rest + , noFusionPreventingPath arcs u v + , cmp u v + , let w = weight u v + , w > 0] + ++ go rest + go [] + = [] + + cmp = typeComparable g trans + + -- Simple trick: + -- if there is an edge between the two, + -- there will be some cache locality benefit from merging + -- otherwise, + -- the only benefit is reducing loop overhead + -- + -- Another heuristic would be to count nodes with shared parents as having a locality benefit + weight u v + -- An edge between them + | (_:_) <- filter (\((i,j),_) -> (u,v) == (i,j) || (v,u) == (i,j)) arcs + = bigN * bigN + + -- Share a parent + | ius <- map (fst.fst) $ filter (\((_,j),_) -> j == u) arcs + , ivs <- map (fst.fst) $ filter (\((_,j),_) -> j == v) arcs + , _:_ <- filter (flip elem ius) ivs + + -- Assume that this is for an array. + = bigN * bigN + | otherwise + = 1 + + +-- | Create linear program for graph, and put all the pieces together. +lp :: (Ord n, Eq t) => Graph n t -> TransducerMap n -> Program (ZVar n) (RVar n) IntDouble +lp g trans + = minimise (gobjective names weights) + (getConstraints nNodes g arcs weights trans) + (getBounds names weights) + where + g' = listOfGraph g + names = map fst $ fst g' + arcs = snd g' + + weights = clusterings arcs names nNodes g trans + + nNodes + = numNodes g + + +-- | Find a good clustering for some graph. +-- The output is: +-- (Pi, Type number) -> list of nodes +solve_linear :: (Ord n, Eq t, Show n, Pretty n) => Graph n t -> TransducerMap n -> [[n]] +solve_linear g trans + = case solve lp's of + Left e -> error (show e) + Right ass -> Map.elems + $ fixMap (sub `mappend` ass) + where + lp' = lp g trans + {- show_lp = CPr.ppr (show.ppr) (show.ppr) -} + + lp'c = Conv.program lp' + -- Simplify can return a (Left InfeasibleError) if the program can't be solved, + -- but we luckily have a proof that the programs we generate will always be feasible. + Right (sub, lp's) = CSimp.simplify lp'c + + + fixMap ass@(Assignment mz _r) + = reorder ass $ snd $ fillMap $ Map.foldWithKey go (0 :: Int, Map.empty) mz + + go k v (n, m) + -- SameCluster i j = 0 --> i and j must be fused together + | SameCluster i j <- k + , v == 0 + = case (Map.lookup i m, Map.lookup j m) of + (Just iC, Just jC) + -> if iC == jC + then (n, m) + else (n, Map.map (\x -> if x == iC then jC else x) m) + (Just iC, Nothing) + -> (n, Map.insert j iC m) + (Nothing, Just jC) + -> (n, Map.insert i jC m) + (Nothing, Nothing) + -> ( n + 1 + , Map.insert i n + $ Map.insert j n m) + + | otherwise + = (n, m) + + fillMap (n, m) + = foldr goFill (n, m) (fst $ listOfGraph g) + + goFill (k,_ty) (n, m) + | Map.member k m + = (n, m) + | otherwise + = ( n + 1 + , Map.insert k n m) + + + reorder ass m + = Map.fromList + $ map (reorder' ass) + $ Map.toList $ invertMap m + + reorder' ass (k,v:vs) + = let k' = rOf ass (Pi v) + in ((truncate k' :: Int, k), v:vs) + reorder' _ (_, []) + = error "ddc-core-flow:DDC.Core.Flow.Transform.Rates.Linear: impossible, empty list in inverted map" + diff --git a/DDC/Core/Flow/Transform/Rates/CnfFromExp.hs b/DDC/Core/Flow/Transform/Rates/CnfFromExp.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Rates/CnfFromExp.hs @@ -0,0 +1,206 @@ +module DDC.Core.Flow.Transform.Rates.CnfFromExp + (cnfOfExp, takeXLamFlags_safe) where +import DDC.Core.Collect +import DDC.Core.Flow.Exp.Simple.Collect () +import DDC.Core.Flow.Compounds +import DDC.Core.Flow.Prim +import DDC.Core.Flow.Exp +import DDC.Core.Flow.Transform.Rates.Fail +import DDC.Core.Flow.Transform.Rates.Combinators as CNF +import qualified DDC.Type.Env as Env + +import Control.Monad +import Data.List (intersect, nub) +import Data.Maybe (catMaybes) +import Data.Monoid +import qualified Data.Set as Set + + +----------------------------------- +-- = Conversion from ExpF to CNF. +-- +-- | Convert a given expression function to CNF. +-- For this to succeed, the function must: +-- - be in A-normal form, *except* worker functions should also be inlined +-- - all bindings are named, not de Bruijn indices +-- - names must be unique +-- - no recursive bindings +-- - no @letregion@s +-- +-- If it succeeds, it should be true that +-- >>> expOfCnf . right . cnfOfExp = id +-- at least semantically, if not syntactically +-- +cnfOfExp :: ExpF -> Either ConversionError (Program Name Name) +cnfOfExp fun + = do -- Peel off the lambdas + let (lams, body) = takeXLamFlags_safe fun + -- Assuming the body is already in a-normal form. + (lets, xx) = splitXLets body + + -- Split into name and values and warn for recursive bindings + binds <- takeLets lets + + let lam_names = catMaybes $ map (takeNameOfBind . snd) lams + let names = lam_names ++ map fst binds + -- Make sure names are unique + when (length names /= length (nub names)) $ + Left FailNamesNotUnique + + -- For each value-level lambda binder, decide whether it's scalar or vector based on type + let inputs = mconcat $ map getInput lams + getInput (False, BName n ty) + -- Vectors on the right, scalars on the left + | isTypeArray ty + = ([],[n]) + | otherwise + = ([n],[]) + getInput (_,_) = ([],[]) + + -- For each binding, classify it as either array, scalar or external. + -- + -- We must be careful about creating externals, though: if a binding is just a + -- worker function, we don't really need that as an external. + -- However, if we assume that all scalars will be fusion-preventing (they currently are), + -- then creating externals for these will not affect scheduling. + -- But what of worker functions referencing vectors? It becomes harder to outlaw if the + -- worker function is not inlined into the combinator binding. + -- Tuples are another potential problem here: looking at the tuple's type, it would not be + -- an array binding. + let (binds', env') = getBinds binds inputs + let outs = localEnv env' xx + + return (Program inputs binds' outs) + +-- | Check if type is an array type, so we know whether variables are scalar or array. +-- This is perhaps a crude way to test, as what if the result of a fold is actually a vector? +-- Well, let's not worry about that right now. +isTypeArray :: TypeF -> Bool +isTypeArray = isVectorType + + +getBinds :: [(Name,(TypeF,ExpF))] -> ([Name],[Name]) -> ([CNF.Bind Name Name], ([Name],[Name])) +getBinds bs env + = go bs env + where + go [] e = ([], e) + go (b:rest) e + = let b' = getBind b e + e' = envOfBind b' <> e + (rest',e'') = go rest e' + in (b' : rest', e'') + + +-- | Convert an epression to a CNF binding. +-- Assuming the incoming expression is well typed, this should never fail: +-- if we can't convert it to a "real" combinator, it will just be converted to an external. +-- +-- Perhaps this is the wrong approach, and if a vector operator cannot be converted, +-- it should be an error or warning. +getBind :: (Name,(TypeF,ExpF)) -> ([Name], [Name]) -> CNF.Bind Name Name +getBind (nm,(t,x)) env + -- Try to match against a known vector combinator. + | Just (f, args) <- takeXApps x + , XVar (UPrim (NameOpVector ov) _) <- f + -- throw away that pesky type information + , args' <- filter ((==Nothing) . takeXType) args + = case (ov, args') of + (OpVectorReduce, [worker, seed, arr]) + | Just fun <- getFun worker + , snm <- name seed + , Just a <- name arr + -> SBind nm (Fold fun (Scalar seed snm) a) + + (OpVectorMap n, worker : arrs) + | Just fun <- getFun worker + , Just as <- names arrs + , length arrs == n + -> ABind nm (MapN fun as) + + (OpVectorFilter, [worker, arr]) + | Just fun <- getFun worker + , Just a <- name arr + -> ABind nm (Filter fun a) + + (OpVectorGenerate, [sz, worker]) + | Just fun <- getFun worker + , snm <- name sz + -> ABind nm (Generate (Scalar sz snm) fun) + + (OpVectorGather, [v, ix]) + | Just v' <- name v + , Just ix' <- name ix + -> ABind nm (Gather v' ix') + + _ | otherwise + -> external + + -- It's not a vector combinator, so we'll have to create an external binding for it. + | otherwise + = external + where + external + = let ins = localEnv env x + out | isTypeArray t = NameArray nm + | otherwise = NameScalar nm + in Ext out x ins + + names as + | xs <- catMaybes $ map name as + , length xs == length as + = Just xs + | otherwise + = Nothing + + name xx + | XVar (UName n) <- xx + = Just n + | otherwise + = Nothing + + -- Try to extract a worker function from an expression. + -- This fails if the worker function mentions any local arrays. + -- I'm not sure if failing in this case is strictly necessary; it should just be nonfusible edges. + getFun xx + = let (ss, as) = localEnv env xx + -- Check that no local arrays are referenced + in if null as + then Just $ Fun xx ss + else Nothing + + +-- | Find local variables that are mentioned in expression, sorted into scalar and array +localEnv :: ([Name],[Name]) -> ExpF -> ([Name],[Name]) +localEnv env xx + -- Get all the free variables mentioned in exp + = let free = catMaybes + $ map takeNameOfBound + $ Set.toList + $ freeX Env.empty xx + -- Limit to just the scalar references + ss = free `intersect` fst env + -- and array refs + as = free `intersect` snd env + -- Check that no local arrays are referenced + in (ss, as) + + +-- | Peel the lambdas off, or leave it alone if there are none +takeXLamFlags_safe x + | Just (binds, body) <- takeXLamFlags x + = (binds, body) + | otherwise + = ([], x) + + +-- | Split into name and values and error for outlawed bindings +takeLets :: [LetsF] -> Either ConversionError [(Name, (TypeF, ExpF))] +takeLets lets + = mapM get lets + where + get (LLet (BName n t) x) = return (n,(t,x)) + get (LLet (BNone _) _) = Left FailNoAnonAllowed + get (LLet (BAnon _) _) = Left FailNoDeBruijnAllowed + get (LRec _ ) = Left FailRecursiveBindings + get (LPrivate _ _ _) = Left FailLetRegionNotHandled + diff --git a/DDC/Core/Flow/Transform/Rates/Combinators.hs b/DDC/Core/Flow/Transform/Rates/Combinators.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Rates/Combinators.hs @@ -0,0 +1,304 @@ +-- | Converting DDC expressions to and from Combinator Normal Form. +module DDC.Core.Flow.Transform.Rates.Combinators + ( Fun(..), Bind(..), ABind(..), SBind(..), Scalar(..) + , Program(..) + , CName(..) + , lookupA, lookupS, lookupB + , envOfBind + , freeOfBind, cnameOfBind + , outputsOfCluster, inputsOfCluster + , seriesInputsOfCluster + ) +where +import DDC.Data.Pretty +import DDC.Core.Flow.Exp (ExpF) +import Data.Maybe (catMaybes) +import Data.List (nub) +import Prelude hiding ((<$>)) + +----------------------------------- +-- = Combinator normal form. + + +-- | Worker function. May only reference scalars in the environment, not arrays. +-- Takes the expression of the function, and a list of the free scalars that are referenced inside it. +-- The expression must be a function from scalar to scalar. +data Fun s a + = Fun ExpF [s] + deriving Show + +-- | Array, scalar and external bindings. +-- Array bindings are those whose value is an array, such as map, filter. +-- Scalar bindings have scalar values, currently only fold. +-- External expressions are those that cannot be converted to primitive combinators. +-- The they take a single expression that computes all outputs, with the list of free scalar and array inputs. +data Bind s a + = ABind a (ABind s a) + | SBind s (SBind s a) + | Ext + { _beOut :: CName s a + , _beExp :: ExpF + , _beIns :: ([s], [a]) + } + deriving Show + +-- | An array-valued binding. +data ABind s a + -- | map_n :: (a_1 ... a_n -> b) -> Array a_1 ... Array a_n -> Array b + = MapN (Fun s a) [a] + -- | filter :: (a -> Bool) -> Array a -> Array a + | Filter (Fun s a) a + -- | generate :: Nat -> (Nat -> a) -> Array a + | Generate (Scalar s a) (Fun s a) + -- | gather :: Array a -> Array Nat -> Array a + | Gather a a + -- | cross :: Array a -> Array b -> Array (a, b) + | Cross a a + deriving Show + +-- | Scalars can either be a literal such as "0", or a named scalar reference. +-- If it's not a named scalar reference, we need to keep the expression so we can reconstruct it later. +-- (We do not have array literals, so this is only necessary for scalars) +data Scalar s a + = Scalar ExpF (Maybe s) + deriving Show + +-- | A scalar-valued binding +data SBind s a + -- | fold :: (a -> a -> a) -> a -> Array a -> a + = Fold (Fun s a) (Scalar s a) a + deriving Show + +-- | An entire program/function to find a fusion clustering for +data Program s a + = Program + { _ins :: ([s], [a]) + , _binds :: [Bind s a] + , _outs :: ([s], [a]) + } + deriving Show + +-- | Name of a combinator. +-- This will also be the name of the corresponding node of the graph. +data CName s a + = NameScalar s + | NameArray a + deriving (Eq, Ord, Show) + + +lookupA :: Eq a => Program s a -> a -> Maybe (ABind s a) +lookupA p a + = go $ _binds p + where + go [] = Nothing + go (ABind a' b : _) + | a == a' + = Just b + go (_ : bs) + = go bs + +lookupS :: Eq s => Program s a -> s -> Maybe (SBind s a) +lookupS p s + = go $ _binds p + where + go [] = Nothing + go (SBind s' b : _) + | s == s' + = Just b + go (_ : bs) + = go bs + + +lookupB :: (Eq s, Eq a) => Program s a -> CName s a -> Maybe (Bind s a) +lookupB p nm = go (_binds p) + where + go [] = Nothing + go (b@(ABind a _) : _) + | NameArray a' <- nm + , a == a' + = Just b + go (b@(SBind s _) : _) + | NameScalar s' <- nm + , s == s' + = Just b + go (b@(Ext nm' _ _) : _) + | nm == nm' + = Just $ b + go (_ : bs) + = go bs + + + +envOfBind :: Bind s a -> ([s], [a]) +envOfBind (SBind s _) = ([s], []) +envOfBind (ABind a _) = ([], [a]) +envOfBind (Ext (NameScalar s) _ _) = ([s], []) +envOfBind (Ext (NameArray a) _ _) = ([], [a]) + + +cnameOfBind :: Bind s a -> CName s a +cnameOfBind (SBind s _) = NameScalar s +cnameOfBind (ABind a _) = NameArray a +cnameOfBind (Ext n _ _) = n + +freeOfBind :: Bind s a -> [CName s a] +freeOfBind b + = case b of + SBind _ (Fold fun i a) + -> ffun fun ++ fscalar i ++ [fa a] + ABind _ (MapN fun as) + -> ffun fun ++ map fa as + ABind _ (Filter fun a) + -> ffun fun ++ [fa a] + ABind _ (Generate s fun) + -> ffun fun ++ fscalar s + ABind _ (Gather x y) + -> [fa x, fa y] + ABind _ (Cross x y) + -> [fa x, fa y] + Ext _ _ (inS,inA) + -> map fs inS ++ map fa inA + where + ffun (Fun _ f) = map fs f + fscalar (Scalar _ Nothing) = [] + fscalar (Scalar _ (Just s)) = [NameScalar s] + fs = NameScalar + fa = NameArray + +-- | Get inputs that must be converted to series or rate vectors +seriesInputOfBind :: Bind s a -> [a] +seriesInputOfBind b + = case b of + SBind _ (Fold _fun _i a) + -> [a] + ABind _ (MapN _fun as) + -> as + ABind _ (Filter _fun a) + -> [a] + ABind _ (Generate _s _fun) + -> [] + ABind _ (Gather v ix) + -- Only the indices array is consumed series-wise. + -- The vector is random access. + -> [v, ix] + -- Cross product's first is consumed in series, but second is consumed multiple times + ABind _ (Cross x y) + -> [x, y] + -- Externals do not require series inputs. + Ext _ _ (_inS,_inA) + -> [] + + + +-- | For a given program and list of nodes that will be clustered together, +-- find a list of the nodes that are used afterwards. +-- Only these nodes must be made manifest. +-- The output nodes is a subset of the input cluster nodes. +outputsOfCluster :: (Eq s, Eq a) => Program s a -> [CName s a] -> [CName s a] +outputsOfCluster prog cluster + -- Get all bindings in the program that aren't in this cluster + = let notin = filter (not . flip elem cluster . cnameOfBind) (_binds prog) + -- And find their free variables + frees = concatMap freeOfBind notin + + -- Convert the returns of the program to CNames + (ss,as) = _outs prog + pouts = map NameScalar ss ++ map NameArray as + + -- We want to look in both returns and free variables of bindings + alls = frees ++ pouts + -- Now search through and find those in the cluster + found = filter (flip elem cluster) alls + in nub $ found + + +-- | For a given program and list of nodes that will be clustered together, +-- find a list of the nodes that are used as inputs. +-- The input nodes will not mention any of the cluster nodes. +inputsOfCluster :: (Eq s, Eq a) => Program s a -> [CName s a] -> [CName s a] +inputsOfCluster prog cluster + -- Get bindings of clusters + = let binds = catMaybes + $ map (lookupB prog) cluster + -- And find the free variables + frees = concatMap freeOfBind binds + + -- Ignore the ones in the cluster + found = filter (not . flip elem cluster) frees + in nub $ found + +-- | For a given program and list of nodes that will be clustered together, +-- find a list of the inputs that need to be converted to series. +-- If the cluster is correct, these should all be the same size. +seriesInputsOfCluster :: (Eq s, Eq a) => Program s a -> [CName s a] -> [a] +seriesInputsOfCluster prog cluster + -- Get bindings of clusters + = let binds = catMaybes + $ map (lookupB prog) cluster + -- And find the free variables + frees = concatMap seriesInputOfBind binds + + -- Ignore the ones in the cluster + found = filter (not . flip elem cluster . NameArray) frees + in nub $ found + + +----------------------------------- +-- == Pretty printing +-- This is just the notation I used in the prototype. + +instance Pretty s => Pretty (Fun s a) where + ppr (Fun _ ss) + = encloseSep lbrace rbrace space + $ map ppr ss + +instance Pretty s => Pretty (Scalar s a) where + ppr (Scalar _ Nothing) + = text "-" + ppr (Scalar _ (Just s)) + = ppr s + +instance (Pretty s, Pretty a) => Pretty (Bind s a) where + ppr (SBind n (Fold f i a)) + = bind (ppr n) "reduce" (ppr f <+> ppr i <+> ppr a) + + ppr (ABind n (MapN f as)) + = bind (ppr n) "mapN" (ppr f <+> hsep (map ppr as)) + + ppr (ABind n (Filter f a)) + = bind (ppr n) "filter" (ppr f <+> ppr a) + + ppr (ABind n (Gather a b)) + = bind (ppr n) "gather" (ppr a <+> ppr b) + + ppr (ABind n (Generate sz f)) + = bind (ppr n) "generate" (ppr sz <+> ppr f) + + ppr (ABind n (Cross a b)) + = bind (ppr n) "cross" (ppr a <+> ppr b) + + ppr (Ext out _ ins) + = bind (ppr out) "external" (binds ins) + where + binds (ss,as) + = encloseSep lbrace rbrace space (map ppr ss) <+> hcat (map ppr as) + +bind :: Doc -> String -> Doc -> Doc +bind nm com args + = nm <+> nest 4 (equals <+> text com <+> args) + +instance (Pretty s, Pretty a) => Pretty (Program s a) where + ppr (Program ins binds outs) + = params <$> vcat (map ppr binds) <$> returns + where + params + = vcat (map (\i -> text "param scalar" <+> ppr i) (fst ins)) + <$> vcat (map (\i -> text "param array" <+> ppr i) (snd ins)) + + returns + = vcat (map (\i -> text "return" <+> ppr i) (fst outs)) + <$> vcat (map (\i -> text "return" <+> ppr i) (snd outs)) + +instance (Pretty s, Pretty a) => Pretty (CName s a) where + ppr (NameScalar s) = text "{" <> ppr s <> text "}" + ppr (NameArray a) = ppr a diff --git a/DDC/Core/Flow/Transform/Rates/Fail.hs b/DDC/Core/Flow/Transform/Rates/Fail.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Rates/Fail.hs @@ -0,0 +1,59 @@ +module DDC.Core.Flow.Transform.Rates.Fail + ( Fail (..) + , ConversionError (..) + , LogFailures + , warn, run) +where +import DDC.Core.Flow.Prim +import DDC.Data.Pretty +import Control.Monad.Writer +import Data.List + +-- | Why couldn't it be converted to CNF? +data ConversionError + -- | Function is not in a-normal form + = FailNotANormalForm + + -- | Bindings must be unique + | FailNamesNotUnique + + -- | Bindings must be named + | FailNoDeBruijnAllowed + + -- | Bindings cannot be anonymous _. + | FailNoAnonAllowed + + -- | Function contains letrec + | FailRecursiveBindings + + -- | Function contains letregion + | FailLetRegionNotHandled + deriving (Show, Eq) + + +-- | Why can't rates be inferred? +data Fail + -- | The function couldn't be converted to combinator form + = FailCannotConvert ConversionError + -- | The constraint would require a buffer. User must expicitly buffer. + | FailConstraintFilteredLessFiltered Name Name + + -- | The constraint would require a buffer. User must expicitly buffer. + | FailConstraintFilteredNotUnique Name Name + deriving (Show, Eq) + + +instance Pretty Fail where + ppr fails = text (show fails) + + +type LogFailures a = Writer [Fail] a + +warn :: Fail -> LogFailures () +warn w = tell [w] + +run :: LogFailures a -> (a, [Fail]) +run comp + = case runWriter comp of + (a, warns) -> (a, nub warns) + diff --git a/DDC/Core/Flow/Transform/Rates/Graph.hs b/DDC/Core/Flow/Transform/Rates/Graph.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Rates/Graph.hs @@ -0,0 +1,229 @@ +module DDC.Core.Flow.Transform.Rates.Graph + ( Graph(..) + , Edge + , graphOfBinds + , graphTopoOrder + , mergeWeights + , invertMap + , numNodes, numEdges + , hasNode, hasEdge + , nodeInputs, nodeInEdges + , nodeType + , listOfGraph, graphOfList ) +where +import DDC.Core.Flow.Transform.Rates.Combinators +import DDC.Core.Flow.Transform.Rates.SizeInference + +import Data.List (nub) +import qualified Data.Map as Map +import qualified Data.Set as Set + + +-- | Graph for function +-- Each node is a binding, edges are dependencies, and the bool is whether the node's output +-- can be fused or contracted. +-- For example, filter and map dependencies can be contracted, +-- but a fold cannot as it must consume the entire stream before producing output. +-- + +type Edge n = (n, Bool) +data Graph n t = Graph (Map.Map n (Maybe t, [Edge n])) + + +graphOfBinds :: (Ord s, Ord a) => Program s a -> Env a -> Graph (CName s a) (Type a) +graphOfBinds prog env + = Graph $ graph + where + graph + = Map.fromList + $ map gen + $ _binds prog + + gen b + = let n = cnameOfBind b + ty = iter prog env n + es = edges n b + in (n, (ty, es)) + + edges n (ABind _ (Gather a b)) + = let a' = mkedgeA (const False) a + b' = mkedgeA (inedge n) b + in [a', b'] + + edges n (ABind _ (Cross a b)) + = let a' = mkedgeA (inedge n) a + b' = mkedgeA (const False) b + in [a', b'] + + edges n b + = let fs = freeOfBind b + fs' = map (pairon (inedge n)) fs + in fs' + + mkedgeA f a + = (pairon f (NameArray a)) + + pairon f x + = (x, f x) + + inedge to from + -- scalar output: + | NameScalar _ <- from + = False + | Just (Ext{}) <- lookupB prog from + = False + | Just (Ext{}) <- lookupB prog to + = False + | otherwise + = True + + + + +-- | Find topological ordering of DAG +-- Does not check for cycles - really must be a DAG! +graphTopoOrder :: Ord n => Graph n t -> [n] +graphTopoOrder (Graph graph) + = reverse $ go ([], Map.keysSet graph) + where + go (l, s) + = case Set.minView s of + Nothing + -> l + Just (m, _) + -> go (visit (l,s) m) + + visit (l,s) m + | Set.member m s + , (_ty, edges) <- graph Map.! m + = let pres = map fst edges + s' = Set.delete m s + (l',s'') = foldl visit (l,s') pres + in (m : l', s'') + + | otherwise + = (l,s) + + + +-- | Merge nodes together with same value in weight map. +-- Type information of each node is thrown away. +-- It is, perhaps surprisingly, legal to merge nodes of different types (eg filtered data), +-- so the only sensible thing is to choose () for all new types. +mergeWeights :: Ord n => Graph n t -> Map.Map n Int -> Graph n () +mergeWeights g@(Graph graph) weights + = Graph + $ foldl go Map.empty + $ graphTopoOrder g + where + go m node + -- Merge if it's a weighted one + | Just k <- name_maybe node + = merge node k m + | otherwise + = merge node node m + + merge node k m + | Just (_ty,edges) <- Map.lookup node graph + = let edges' = nub $ map (\(n,f) -> (name n, f)) edges + in Map.insertWith ins k (Nothing,edges') m + | otherwise + = m + + ins (_, e1) (_, e2) + = (Nothing, nub $ e1 ++ e2) + + weights' = invertMap weights + + name n + = maybe n id (name_maybe n) + + -- If this node is mentioned in the weights map, then find some canonical name for it. + name_maybe n + | Just i <- Map.lookup n weights + , Just (v:_) <- Map.lookup i weights' + = Just v + | otherwise + = Nothing + + +invertMap :: Ord v => Map.Map k v -> Map.Map v [k] +invertMap m + = Map.foldWithKey go Map.empty m + where + go k v m' = Map.insertWith (++) v [k] m' + + +-- | Number of nodes in graph +numNodes :: Graph n t -> Int +numNodes (Graph g) + = Map.size g + +-- | Total number of edges in graph +numEdges :: Graph n t -> Int +numEdges (Graph g) + = Map.fold (+) 0 + $ Map.map (length . snd) g + + +hasNode :: Ord n => Graph n t -> n -> Bool +hasNode (Graph gmap) k + = k `Map.member` gmap + +hasEdge :: Ord n => Graph n t -> (n,n) -> Bool +hasEdge g (i,j) + = i `elem` nodeInputs g j + +nodeInputs :: Ord n => Graph n t -> n -> [n] +nodeInputs g k + = map fst + $ nodeInEdges g k + +nodeInEdges :: Ord n => Graph n t -> n -> [(n,Bool)] +nodeInEdges (Graph gmap) k + | Just (_,es) <- Map.lookup k gmap + = es + | otherwise + = [] + + +-- | Find type, or iteration size, of node, if it has one. +-- An external can't be represented as a loop, so it will be Nothing. +-- Similarly with input nodes. +nodeType :: Ord n => Graph n t -> n -> Maybe t +nodeType (Graph gmap) k + | Just (Just na,_) <- Map.lookup k gmap + = Just na + | otherwise + = Nothing + + +-- | Convert @Graph@ to a lists of nodes and a list of edges +listOfGraph :: Graph n t -> ([(n,Maybe t)], [((n,n),Bool)]) +listOfGraph (Graph g) + = (nodes, edges) + where + gl = Map.toList g + + nodes = map (\(k,(na,_)) -> (k,na)) gl + edges = concatMap (\(k,(_,es)) -> map (\(k',ea) -> ((k,k'),ea)) es) gl + + +-- | Convert lists of nodes and list of edges to a @Graph@ +graphOfList :: Ord n => ([(n,Maybe t)], [((n,n),Bool)]) -> Graph n t +graphOfList (nodes, edges) + = Graph + $ addEdges nodeMap + where + nodeMap + = Map.fromList + $ map (\(k,na) -> (k,(na,[]))) + $ nodes + + addEdges g + = foldl insE g edges + + insE g ((k,k'),ea) + = Map.adjust (\(na,es) -> (na, (k',ea):es)) + k g + diff --git a/DDC/Core/Flow/Transform/Rates/SeriesOfVector.hs b/DDC/Core/Flow/Transform/Rates/SeriesOfVector.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Rates/SeriesOfVector.hs @@ -0,0 +1,532 @@ + +module DDC.Core.Flow.Transform.Rates.SeriesOfVector + (seriesOfVectorModule + ,seriesOfVectorFunction) +where +import DDC.Core.Flow.Compounds +import DDC.Core.Flow.Prim +import DDC.Core.Flow.Exp as DDC +import DDC.Core.Flow.Transform.Rates.Combinators as Com +import DDC.Core.Flow.Transform.Rates.CnfFromExp +import DDC.Core.Flow.Transform.Rates.Fail +import DDC.Core.Flow.Transform.Rates.Graph +import DDC.Core.Flow.Transform.Rates.Clusters +import DDC.Core.Flow.Transform.Annotate +import DDC.Core.Flow.Transform.Deannotate +import DDC.Core.Module +import DDC.Core.Collect +import qualified DDC.Core.Flow.Transform.Rates.SizeInference as SI +import qualified DDC.Type.Env as Env + +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Set as Set +import Data.List (partition) + + +seriesOfVectorModule :: ModuleF -> (ModuleF, [(Name,Fail)]) +seriesOfVectorModule mm + = let body = deannotate (const Nothing) + $ moduleBody mm + + (lets, xx) = splitXLets body + letsErrs = map seriesOfVectorLets lets + + lets' = concatMap fst letsErrs + errs = concatMap snd letsErrs + + body' = annotate () + $ xLets lets' xx + + + in (mm { moduleBody = body' }, errs) + + + +seriesOfVectorLets :: LetsF -> ([LetsF], [(Name,Fail)]) +seriesOfVectorLets ll + | LLet b@(BName n _) x <- ll + , (x',ls',errs) <- seriesOfVectorFunction x + = ( map (uncurry LLet) ls' ++ [LLet b x'] + , map (\f -> (n,f)) errs) + + | LRec bxs <- ll + , (bs,xs) <- unzip bxs + , (xs',ls', _errs) <- unzip3 $ map seriesOfVectorFunction xs + = ( [LRec (concat ls' ++ (bs `zip` xs'))] + , []) + -- We still need to produce errors if this doesn't work. + + | otherwise + = ([ll], []) + + +-- | Takes a single function body. Function body must be in a-normal form. +seriesOfVectorFunction :: ExpF -> (ExpF, [(BindF,ExpF)], [Fail]) +seriesOfVectorFunction fun + = case cnfOfExp fun of + Left err + -> (fun, [], [FailCannotConvert err]) + Right prog + -> case SI.generate prog of + Nothing + -> (fun, [], []) + + Just (env,_s) + -> let g = graphOfBinds prog env + tmap a b = SI.parents prog env a b + clusters = cluster g tmap + (re, ls) = reconstruct fun prog env clusters + in (re, ls, []) + + +reconstruct + :: ExpF + -> Program Name Name + -> SI.Env Name + -> [[CName Name Name]] + -> (ExpF, [(BindF, ExpF)]) +reconstruct fun prog env clusters + = (makeXLamFlags lams + $ xLets lets' xx + , procs) + where + + (lams, body) = takeXLamFlags_safe fun + (olds, xx) = splitXLets body + + types = takeTypes (concatMap valwitBindsOfLets olds ++ map snd lams) + + lets = concatMap convert clusters + (lets', procs) = extractProcs lets lams + + convert c + = let outputs = outputsOfCluster prog c + + arrIns = seriesInputsOfCluster prog c + + -- Map over the list of all binds and find only those that we want. + -- This way is better than mapping lookup over c, as we get them in program order. + binds = filter (flip elem c . cnameOfBind) (_binds prog) + binds' = map (\a -> (a, cnameOfBind a `elem` outputs)) binds + in mkLets types env arrIns binds' + + +-- | Extract processes out so they can be made into separate bindings +extractProcs :: [LetsF] -> [(Bool, DDC.Bind Name)] -> ([LetsF], [(BindF,ExpF)]) +extractProcs lets env + = go lets $ env + where + go [] _ + = ([], []) + + go (l:ls) e + -- Actually, we know they're all LLets. Maybe it should just be (Name,ExpF) + | LLet b x <- l + , BName nm _ <- b + = let this = go1 b nm x e + rest = go ls ((False,b) : e) + in this `mappend` rest + + | otherwise + = ([l],[]) `mappend` go ls e + + go1 b nm x e + | Just (op, args) <- takeXApps x + , XVar (UPrim (NameOpSeries (OpSeriesRateVecsOfVectors n)) _) <- op + , (xs, [lam]) <- splitAt (length args - 1) args + , (lams,body) <- takeXLamFlags_safe lam + , ([LLet n' x'], binds) <- go1 b nm body (lams ++ e) + = ([LLet n' + (xApps (xVarOpSeries (OpSeriesRateVecsOfVectors n)) + (xs ++ [makeXLamFlags lams x']))] + , binds) + + | Just (op, args) <- takeXApps x + , XVar (UPrim (NameOpSeries OpSeriesRunProcess) _) <- op + , (xs, [lam]) <- splitAt (length args - 1) args + + = let fsX = freeX Env.empty lam + fsT = freeT Env.empty lam + + isMentioned (ty,bo) + | Just bo' <- takeSubstBoundOfBind bo + = if ty + then Set.member bo' fsT + else Set.member bo' fsX + | otherwise + = False + + os = filter isMentioned e + + ss = takeSubstBoundsOfBinds . map snd + osT = filter (fst) os + osX = filter (not.fst) os + + nm' = NameVarMod nm "process" + + x' = xApps op (xs ++ + [xApps (XVar $ UName nm') + ( map (XType . TVar) (ss osT) + ++ map XVar (ss osX))]) + + p' = makeXLamFlags (osT ++ osX) lam + in ([LLet b x'], [(BName nm' (tBot kData), p')]) + + | otherwise + = ([LLet b x], []) + +-- | Make "lets" for a cluster. +-- If it's external, this is trivial. +-- If not, make a runProcess# etc +mkLets :: Map Name TypeF -> SI.Env Name -> [Name] -> [(Com.Bind Name Name, Bool)] -> [LetsF] +mkLets types env arrIns bs + | any isExt (map fst bs) + = case bs of + [(Ext (NameArray b) xx _, _)] -> [LLet (BName b (types Map.! b)) xx] + [(Ext (NameScalar b) xx _, _)] -> [LLet (BName b (types Map.! b)) xx] + + _ -> error ("ddc-core-flow:DDC.Core.Flow.Transform.Rates.SeriesOfVector impossible\n" ++ + "an external node has been clustered with another node.\n" ++ + "this means there must be a bug in the clustering algorithm.\n" ++ + show bs) + + -- We *could* just return an empty list in this case, but I don't think that's a good idea. + | [] <- bs + = error ("ddc-core-flow:DDC.Core.Flow.Transform.Rates.SeriesOfVector impossible\n" ++ + "a cluster was created with no bindings.\n" ++ + "this means there must be a bug in the clustering algorithm.\n" ++ + show bs) + + | otherwise + = process types env arrIns + $ map toEither bs + + where + isExt (Ext{}) = True + isExt _ = False + + toEither (SBind s b, out) = ((s, Left b), out) + toEither (ABind a b, out) = ((a, Right b), out) + toEither (Ext{}, _) = error "ddc-core-flow.mkLets: impossible!" + + +-- | Create a process for a cluster of array and scalar bindings. +-- No externals. +-- List of bindings cannot be empty +process :: Map Name TypeF + -> SI.Env Name + -> [Name] + -> [((Name, Either (SBind Name Name) (ABind Name Name)), Bool)] + -> [LetsF] +process types env arrIns bs + = let pres = concatMap getPre bs + mid = getRateVecs arrIns + $ getGenerates bs + $ runProcs + $ xLets (map getInSeries arrIns) + $ mkProcs bs + posts = concatMap getPost bs + in pres ++ [LLet (BName (NameVarMod outname "runproc") tUnit) mid] ++ posts + where + getPre b + -- There is no point of having a reduce that isn't returned. + | ((s, Left (Fold _ (Scalar z _) _)), _) <- b + = [LLet (BName (NameVarMod s "ref") $ tRef $ tyOf s) (xNew (tyOf s) z)] + + -- Returned vectors + | ((v, Right _), True) <- b + = [LLet (BName v $ tVector $ sctyOf v) (xNewVector (sctyOf v) allocSize)] + + -- Otherwise, it's not returned or we needn't allocate anything + | _ <- b + = [] + + + getGenerates [] innerX + = innerX + getGenerates (b:rest) innerX + | ((n, Right (Generate (Scalar sz _) _)), _) <- b + , rest' <- getGenerates rest innerX + = xApps (xVarOpSeries (OpSeriesRateVecsOfVectors 0)) + [ XType tUnit + , sz + , XLAM (BName (klokV n) kRate) rest' ] + | otherwise + = getGenerates rest innerX + + getRateVecs [] innerX + = innerX + + getRateVecs (a:as) innerX + | Just t <- SI.lookupV env a + , (same,others) <- partition ((==Just t) . SI.lookupV env) as + , rest' <- getRateVecs others innerX + + , these <- (a : same) + , nums <- length these + + , op <- OpSeriesRateVecsOfVectors nums + + , flags <- map (\n -> (False, BName (NameVarMod n "rv") (tRateVec (klokT a) (sctyOf n)))) these + = xApps (xVarOpSeries op) + ( map xsctyOf these ++ [XType tUnit] + ++ map var these + ++[ makeXLamFlags ((True, BName (klokV a) kRate) : flags) + rest' ] + ) + + -- Input array doesn't have a type.. + | otherwise + = getRateVecs as innerX + + getInSeries n + = LLet (BName (NameVarMod n "s") (tSeries procT (klokT n) (sctyOf n))) + (xApps (xVarOpSeries OpSeriesSeriesOfRateVec) + [ procX, klokX n, xsctyOf n, var $ NameVarMod n "rv" ] ) + + + + getPost b + | ((s, Left (Fold _ (Scalar _ _) _)), _) <- b + = [ LLet (BName s $ sctyOf s) (xRead (tyOf s) (var $ NameVarMod s "ref")) ] + + -- Ignore anything else + | _ <- b + = [] + + runProcs body + = let flags = [ (True, BName procName kProc) + , (False, BNone tUnit) ] + in xApps (xVarOpSeries OpSeriesRunProcess) + ([XType processRate, makeXLamFlags flags body]) + + + mkProcs (b:rs) + | ((s, Left (Fold (Fun xf _) (Scalar xs _) ain)), _) <- b + = let rest = mkProcs rs + in XLet (LLet (BName (NameVarMod s "proc") $ tProcess procT $ klokT ain) + $ xApps (xVarOpSeries OpSeriesReduce) + [ procX, klokX ain, xtyOf s, var (NameVarMod s "ref") + , xf, xs, var (NameVarMod ain "s")]) + rest + + | ((n, Right abind), out) <- b + = let rest = mkProcs rs + n'proc = NameVarMod n "proc" + n's = NameVarMod n "s" + n'flag = NameVarMod n "flags" + n'sel = NameVarMod n "sel" + + llet nm t x1 + = XLet (LLet (BName nm t) x1) + + go | out + = llet n'proc (tProcess procT $ klokT n) + ( xApps (xVarOpSeries OpSeriesFill) [procX, klokX n, xsctyOf n, var $ n, var $ n's] ) + rest + | otherwise + = rest + + in case abind of + MapN (Fun xf _) ains + -> llet n's (tSeries procT (klokT n) $ sctyOf n) + ( xApps (xVarOpSeries (OpSeriesMap (length ains))) + ([procX, klokX n] ++ (map xsctyOf ains) ++ [xsctyOf n, xf] + ++ map (var . flip NameVarMod "s") ains) ) + go + + Filter (Fun xf _) ain + -> llet n'flag (tSeries procT (klokT ain) tBool) + ( xApps (xVarOpSeries (OpSeriesMap 1)) + [ procX, klokX ain, xsctyOf n, XType tBool, xf, var $ NameVarMod ain "s"] ) + $ xApps (xVarOpSeries $ OpSeriesMkSel 1) + [ procX, klokX ain, XType processRate, var n'flag + , XLAM (BName (klokV n) kRate) + $ XLam (BName n'sel (tSel1 procT (klokT ain) (klokT n))) + $ llet n's (tSeries procT (klokT n) $ sctyOf n) + ( xApps (xVarOpSeries OpSeriesPack) + [ procX, klokX ain, klokX n, xsctyOf n + , var n'sel, var $ NameVarMod ain "s"] ) + go ] + + Generate _sz (Fun xf _) + -> llet n's (tSeries procT (klokT n) $ sctyOf n) + ( xApps (xVarOpSeries OpSeriesGenerate) + [ procX, klokX n, xsctyOf n, xf ]) + go + + Gather v ix + -> llet n's (tSeries procT (klokT n) $ sctyOf n) + ( xApps (xVarOpSeries OpSeriesGather) + ([ procX, klokX v, klokX ix, xsctyOf v + , var $ NameVarMod v "rv", var $ NameVarMod ix "s"]) ) + go + Cross _a _b + -> error "ddc-core-flow.process: Cross combinator not implemented yet" + + -- All cases are handled above + | otherwise + = error "ddc-core-flow.process: impossible!" + + + + mkProcs [] + -- bs cannot be empty: there's no point of an empty cluster. + = let procs = concatMap getProc bs + in case procs of + (_:_) -> foldl1 mkJoin $ concatMap getProc bs + [] -> error "ddc-core-flow.process: cluster with no outputs?" + + mkJoin p q + = xApps (xVarOpSeries OpSeriesJoin) [p, q] + + getProc b@((s, Left _), _) + = [resizeProc b $ var $ NameVarMod s "proc"] + getProc b@((a, _), True) + = [resizeProc b $ var $ NameVarMod a "proc"] + getProc _ + = [] + + resizeProc b v + = goResize (fst $ fst b) v (reverse bs) + + goResize _ v [] + = v + goResize n v (((n',b),_):rest) + | n == n' + = case b of + Left (Fold _ _ ain) + -> goResize ain v rest + Right (MapN _ (i:_)) + -> goResize i v rest + Right (MapN _ []) + -> error "ddc-core-flow.process: Map with no inputs." + + Right (Filter _ ain) + -> goResize ain + ( xApps (xVarOpSeries OpSeriesResizeProc) + [ procX, klokX n, klokX ain + , xApps (xVarOpSeries OpSeriesResizeSel1) + [ procX, klokX n, klokX ain, klokX n + , var $ NameVarMod n "sel" + , xApps (xVarOpSeries OpSeriesResizeId) + [ procX, klokX n ] + ] + , v ]) rest + + Right (Generate _ _) + -> v + + Right (Gather _ ain) + -> goResize ain v rest + + Right (Cross a _b) + -> goResize a v rest + + | otherwise + = goResize n v rest + + + allocSize + -- If there are any inputs, use the size of one of those + | (i:_) <- arrIns + = xApps (xVarOpVector OpVectorLength) [xsctyOf i, var i] + -- Or if it's a generate, find the size of the generate expression. + | (Scalar sz _:_) <- concatMap findGenerateSize bs + = sz + -- XXX Otherwise it must be an external, and this won't be called... + | otherwise + = error ("ddc-core-flow: allocSize, but no size known" ++ show arrIns ++ "\n" ++ show bs) + + -- Find the loop rate of the process. + -- Since we don't have appends, it's just the rate of the first binding + processRate + = bindRate (head bs) + + bindRate b + = let k = klokT (fst $ fst b) + in case snd $ fst b of + Left (Fold _ _ ain) + -> klokT ain + Right (MapN _ _) + -> k + Right (Filter _ ain) + -> klokT ain + Right (Generate _ _) + -> k + Right (Gather _ _) + -> k + Right (Cross ain _) + -> klokT ain + + -- We just need a name for the Proc type + procName = NameVarMod outname "PROC" + procT = TVar $ UName $ procName + procX = XType $ procT + + klokV = getKlok env + klokT = TVar . UName . klokV + klokX = XType . klokT + + findGenerateSize ((_, Right (Generate sz _)), _) + = [sz] + findGenerateSize _ + = [] + + + -- We just need to find the name of any binding + -- This head is safe because @mkLets@ will not call @process@ with an empty cluster. + outname + = fst $ fst $ head bs + + tyOf n = types Map.! n + sctyOf = getScalarType . tyOf + xtyOf = XType . tyOf + xsctyOf = XType . sctyOf + + var n = XVar $ UName n + + +xVarOpSeries n = XVar (UPrim (NameOpSeries n) (typeOpSeries n)) +xVarOpVector n = XVar (UPrim (NameOpVector n) (typeOpVector n)) + + +-- | Get underlying scalar of a vector type - or just return original type if it's not a vector. +getScalarType :: TypeF -> TypeF +getScalarType tt + = case takePrimTyConApps tt of + Just (NameTyConFlow TyConFlowVector, [sc]) -> sc + _ -> tt + + +-- | Create map of types of binders +takeTypes :: [DDC.Bind Name] -> Map Name TypeF +takeTypes binds + = Map.fromList $ concatMap get binds + where + get (BName n t) = [(n,t)] + get _ = [] + + +getKlok :: SI.Env Name -> Name -> Name +getKlok e n + | Just t <- SI.lookupV e n + = ty $ goT t + | otherwise + = ty n + where + ty = flip NameVarMod "k" + + goT (SI.TVar kv) + = goKV kv + -- This doesn't matter much.. + goT (SI.TCross ta tb) + = NameVarMod (goT ta) (show tb) + + goKV (SI.KV v) + = v + goKV (SI.K' kv) + = NameVarMod (goKV kv) "'" + + diff --git a/DDC/Core/Flow/Transform/Rates/SizeInference.hs b/DDC/Core/Flow/Transform/Rates/SizeInference.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Rates/SizeInference.hs @@ -0,0 +1,485 @@ +-- | Performing size inference on a program in Combinator Normal Form +module DDC.Core.Flow.Transform.Rates.SizeInference + ( Type(..), K(..), Env, Scope(..), Scheme(..) + , generate + , lookupV + , iter + , parents + , trans ) +where +import DDC.Core.Flow.Transform.Rates.Combinators +import DDC.Data.Pretty + +import Data.List +import Data.Function (on) +import Data.Maybe +import qualified Control.Applicative as A +import Control.Monad + +----------------------------------- +-- = Size types, constraints and schemes + +-- | Given some variable type, append a number of primes onto it. +-- We want to be able to distinguish between the raw variable types and unification, existential Klock (rate) variables. +-- We generate constraints so that raw variables will appear on the left of equalities, and Ks may appear on the right. +data K v + = KV v + | K' (K v) + deriving (Eq,Ord,Show) + + +-- | tau ::= +data Type v + -- | k + = TVar (K v) + -- | tau * tau + | TCross (Type v) (Type v) + deriving (Eq, Ord,Show) + +-- | Find all variables in type +freeT :: Type a -> [K a] +freeT (TVar a) = [a] +freeT (TCross a b) = freeT a ++ freeT b + + +-- | C ::= +data Constraint v + -- | true + = CTrue + -- | v = tau + | CEqual v (Type v) + -- | C /\ C + | CAnd (Constraint v) (Constraint v) + deriving (Show) + +-- | Big conjunction. Join a bunch of constraints together +ands :: [Constraint v] -> Constraint v +ands = foldr CAnd CTrue + +-- | Flatten a set of constraints into a simpler, canonical form. +-- Turn it into a list of variable/type equalities, ordered by variable name. +flatten :: Ord v => Constraint v -> [(v, Type v)] +flatten = sortBy (compare `on` fst) . go + where + go CTrue = [] + go (CEqual v k) = [(v,k)] + go (CAnd a b) = go a ++ go b + +-- | Convert back from flattened form to a set of @Constraint@ +unflatten :: [(v, Type v)] -> Constraint v +unflatten = ands . map (uncurry CEqual) + + +-- | sigma ::= forall k... exists k... (x : t)... -> (x : t)... +-- Note that these are all raw variable types. +-- There is no point mentioning unification variables in this solved form. +data Scheme v + = Scheme + { _forall :: [K v] + , _exists :: [K v] + , _from :: [(v, Type v)] + , _to :: [(v, Type v)] + } + deriving (Show) + + +----------------------------------- +-- = Constraint generation +-- == Environment + +-- | Gamma ::= • | Gamma, Gamma... +type Env v = [Scope v] + +-- | Gamma ::= ... +data Scope v + -- | v : k + = EVar v (Type v) + -- | k + | EUnify (K v) + -- | exists k + | ERigid (K v) + deriving (Show) + +evar :: v -> Scope v +evar v + = EVar v $ TVar $ KV v + + +-- | Search for first (should be only) mention of k in environment, along with its index +lookupV :: Eq v => Env v -> v -> Maybe (Type v) +lookupV es v + = go es + where + go [] = Nothing + go (EVar v' t : _) + | v == v' + = Just t + go (_:es') + = go es' + +-- | Search for first (should be only) mention of k in environment, along with its index +isUnify :: Eq v => Env v -> K v -> Bool +isUnify es k + = go es + where + go [] = False + go (EUnify k' : _) + | k == k' + = True + go (_:es') + = go es' + + +-- | Find all free variables in types of environment +freeE :: Env a -> [K a] +freeE es + = concatMap go es + where + go (EVar _ t) = freeT t + go _ = [] + + +-- == Generation of constraints +-- For example, the program +-- +-- > normalize2 :: Array Int -> (Array Int, Array Int) +-- > normalize2 xs +-- > = let sum1 = fold (+) 0 xs +-- > gts = filter (> 0) xs +-- > sum2 = fold (+) 0 gts +-- > ys1 = map (/ sum1) xs +-- > ys2 = map (/ sum2) xs +-- > in (ys1, ys2) +-- +-- will generate environment and constraints +-- +-- > xs : kxs, gts : kgts, ys1 : kys1, ys2 : kys2, ∃k1, k2, k3 +-- > |- true ∧ kgts = k1 ∧ true +-- > ∧ kxs = k2 ∧ kys1 = k2 ∧ kxs = k3 ∧ kys2 = k3 +-- +-- | program :_s sigma +generate :: Ord a => Program s a -> Maybe (Env a, Scheme a) +generate program@(Program (_inSs,inAs) _binds (_outSs,outAs)) + = do e <- generateEnv program + let fvs = freeE e + + let alls x = case x of + EUnify v | v `elem` fvs -> [v] + _ -> [] + let exis x = case x of + ERigid v | v `elem` fvs -> [v] + _ -> [] + + let us = concatMap alls e + let rs = concatMap exis e + + let inTs = catMaybes $ map (lookupV e) inAs + let ouTs = catMaybes $ map (lookupV e) outAs + + let fvIn = nub $ concatMap freeT inTs + let fvOu = nub $ concatMap freeT ouTs + + -- check if there are any rigids mentioned in input types: + -- this means we'd have an existential input, which is nonsense. + when (any (flip elem rs) fvIn) + Nothing + + let sch = Scheme + { _forall = fvIn `intersect` us + , _exists = fvOu `intersect` rs + , _from = inAs `zip` inTs + , _to = outAs `zip` ouTs + } + return (e, sch) + + +-- | Get environment +generateEnv :: Ord a => Program s a -> Maybe (Env a) +generateEnv (Program (_inSs,inAs) binds _outs) + = do let e = concatMap (\i -> [EUnify (KV i), evar i]) inAs + let (e', c') = generateLets e binds + -- If solve succeeds, there will be no duplicate left-hand sides in c''. + (e'', c'') <- solve e' c' + -- Now, we must group the variables into equivalence classes. + -- Take all the leftover constraints and substitute them into the environment + return $ substEAll c'' e'' + + +-- | Gamma |- lets ~> Gamma |- C +generateLets :: Env a -> [Bind s a] -> (Env a, Constraint a) +generateLets e bs + = foldl go (e, CTrue) bs + where + go (e',c') b + = let (e'', c'') = generateBind e' b + in (e'', c' `CAnd` c'') + +-- | Gamma | z |- bind ~> Gamma |- C +generateBind :: Env a -> Bind s a -> (Env a, Constraint a) +generateBind env b + = case b of + ABind z (MapN _ xs) + -> let u = K' (KV z) + env' = evar z : EUnify u : env + con = ands $ map (\i -> CEqual i (TVar u)) (z : xs) + in (env', con) + + ABind z (Filter _ _) + -> let u = K' (KV z) + env' = evar z : ERigid u : env + con = CEqual z (TVar u) + in (env', con) + + SBind _ (Fold _ _ _) + -> (env, CTrue) + + ABind z (Generate _ _) + -> let u = K' (KV z) + env' = evar z : ERigid u : env + con = CEqual z (TVar u) + in (env', con) + + ABind z (Gather _ i) + -> let u = K' (KV z) + env' = evar z : EUnify u : env + con = CEqual z (TVar u) `CAnd` CEqual i (TVar u) + in (env', con) + + ABind z (Cross x y) + -> let u = K' (KV z) + u' = K' (K' (KV z)) + env' = evar z : EUnify u' : EUnify u : env + con = ands [ CEqual z (TCross (TVar u) (TVar u')) + , CEqual x (TVar u) + , CEqual y (TVar u') ] + in (env', con) + + Ext (NameArray a) _ (_, _) + -> let env' = [evar a, ERigid $ K' $ KV a] ++ env + con = CEqual a $ TVar $ K' $ KV a + in (env', con) + + Ext (NameScalar _) _ (_, _) + -> (env, CTrue) + + + + +-- | Solving constraints. +-- If we take the environment and constraints from @normalize2@, +-- > xs : kxs, gts : kgts, ys1 : kys1, ys2 : kys2, ∃k1, k2, k3 +-- > |- true ∧ kgts = k1 ∧ true +-- > ∧ kxs = k2 ∧ kys1 = k2 ∧ kxs = k3 ∧ kys2 = k3 +-- the constraints can be converted to canonical form by 'flatten': +-- > [kgts = k1, kxs = k2, kxs = k3, kys1 = k2, kys2 = k3] +-- After that, we iterate through the list of constraints, finding duplicate left hand sides. +-- For some duplicate left hand side, such as +-- > kxs = k2, kxs = k3 +-- the k2 and k3 must be unified in Env. +solve :: Ord a => Env a -> Constraint a -> Maybe (Env a, Constraint a) +solve e c + = let cs = flatten c + in go cs e cs + where + go [ ] e' c' = return (e', unflatten c') + go [_] e' c' = return (e', unflatten c') + + go ((x,a):(y,b):rs) e' c' + | x == y + = do sub <- unify e a b + -- Substitute into both the full constraint set, + -- and just those remaining to check + let e'' = substE sub e' + let c'' = substCs sub c' + let rest= substCs sub ((y,b) : rs) + go rest e'' c'' + | otherwise + = go ((y,b) : rs) e' c' + + +-- | A substitution, mapping some variable to a type +type Subst a = [(K a, Type a)] + + +-- | Perform substitution over types +substT :: Ord a => Subst a -> Type a -> Type a +substT sub t@(TVar a) + | Just t' <- lookup a sub + = t' + | otherwise + = t +substT sub (TCross a b) + = TCross (substT sub a) (substT sub b) + + +-- | Perform substitution over already-flattened constraints +substCs :: Ord a => Subst a -> [(a, Type a)] -> [(a, Type a)] +substCs sub cs + = map (\(v,t) -> (v, substT sub t)) cs + + +-- | Perform substitution over environment +substE :: Ord a => Subst a -> Env a -> Env a +substE sub es + = map go es + where + go (EVar v t) = EVar v (substT sub t) + go e = e + + +-- | Take all constraints, treat them as substitutions +substEAll :: Ord a => Constraint a -> Env a -> Env a +substEAll cs es + = substE (map mkSub $ flatten cs) es + where + mkSub (v,t) = (KV v, t) + + +-- | Given two types, find a substitution that unifies the two together +-- The substitution may only change the value of unifier variables +unify :: Ord a => Env a -> Type a -> Type a -> Maybe (Subst a) +unify e l r + = go l r + where + go (TVar a) (TVar b) + | a == b = Just [] + | isUnify e a = Just [(a, TVar b)] + | isUnify e b = Just [(b, TVar a)] + -- Neither variables are unifiers. It cannot be done. + | otherwise = Nothing + + go (TCross a1 a2) (TCross b1 b2) + = (++) A.<$> go a1 b1 A.<*> go a2 b2 + + go (TVar a) b@(TCross _ _) + | isUnify e a + = Just [(a, b)] + | otherwise + = Nothing + + go a@(TCross _ _) (TVar b) + | isUnify e b + = Just [(b, a)] + | otherwise + = Nothing + + +-- = Iteration size and transducers + +-- | Find iteration size of given combinator +iter :: (Eq a, Eq s) => Program s a -> Env a -> CName s a -> Maybe (Type a) +iter program e nm + | NameScalar nm' <- nm + = do b <- lookupS program nm' + case b of + Fold _ _ n -> get n + | NameArray nm' <- nm + = do b <- lookupA program nm' + case b of + MapN{} -> get nm' + Filter _ as -> get as + Generate _ _ -> get nm' + Gather _d is -> get is + Cross as bs -> TCross A.<$> get as A.<*> get bs + -- Otherwise, it's external. + | otherwise + = Nothing + where + get = lookupV e + + +-- | Find a bindings' transducer. +-- Only array bindings can have transducers. +trans :: (Eq a, Eq s) => Program s a -> CName s a -> Maybe (CName s a) +trans bs nm + | NameArray nm' <- nm + , Just (Filter _ n) <- lookupA bs nm' = trans' (NameArray n) + | otherwise = trans' nm + where + trans' (NameScalar o) + = case lookupS bs o of + Just (Fold _ _ n) + -> trans' (NameArray n) + + -- Not a binding, or an external + Nothing + -> Nothing + + trans' (NameArray o) + = case lookupA bs o of + Just (Filter _ _n) + -> Just (NameArray o) + + Just (MapN _ ns) + -> listToMaybe $ catMaybes $ map (trans' . NameArray) ns + Just (Gather _d i) + -> trans' (NameArray i) + + Just (Generate _ _) + -> Nothing + Just (Cross _ _) + -> Nothing + + -- Not a binding, or an external + Nothing + -> Nothing + + +-- | Find pair of parent transducers with same iteration size +parents :: (Eq a, Eq s) => Program s a -> Env a -> CName s a -> CName s a -> Maybe (CName s a, CName s a) +parents bs e a b + | itsz a == itsz b + = Just (a,b) + + | otherwise + = let pas = trans bs a >>= \a'' -> parents bs e a'' b + pbs = trans bs b >>= \b'' -> parents bs e a b'' + ps = catMaybes [pas, pbs] + -- If @b@ is a child of @a@, we want to find the parents @(a,a)@. + -- There may be other parents, but @(a,a)@ is the "most specific". + -- There is actually an error in the paper - nodes may have multiple parents + -- if one node is the parent/transducer of the other. + same= filter (\(a',b') -> a' `elem` [a,b] || b' `elem` [a,b]) ps + in case same of + (s:_) -> Just s + [] -> listToMaybe ps + + where + itsz = iter bs e + +----------------------------------- +-- == Pretty printing + +instance (Pretty v) => Pretty (K v) where + ppr (KV v) = ppr v + ppr (K' v) = ppr v <> squote + +instance (Pretty v) => Pretty (Type v) where + ppr (TVar v) = ppr v + ppr (TCross a b) = ppr a <+> text "*" <+> ppr b + + +instance (Pretty v) => Pretty (Maybe (Type v)) where + ppr (Just t) = ppr t + ppr Nothing = text "(no type)" + +instance (Pretty v) => Pretty (Scope v) where + ppr (EVar v t) = ppr v <+> text ":" <+> ppr t + ppr (EUnify v) = text "∀" <> ppr v + ppr (ERigid v) = text "∃" <> ppr v + +{- +instance (Pretty v) => Pretty (Env v) where + ppr = hcat . map ppr +-} + +instance (Pretty v) => Pretty (Scheme v) where + ppr (Scheme foralls exists from to) + = text "∀" <> hcat (map ppr foralls) <> text ". " + <+> text "∃" <> hcat (map ppr exists) <> text ". " + <+> tupled (map tppr from) <+> text "→" + <+> tupled (map tppr to) + where + tppr (v,t) = ppr v <+> text ":" <+> ppr t + + diff --git a/DDC/Core/Flow/Transform/Schedule.hs b/DDC/Core/Flow/Transform/Schedule.hs --- a/DDC/Core/Flow/Transform/Schedule.hs +++ b/DDC/Core/Flow/Transform/Schedule.hs @@ -1,252 +1,13 @@ module DDC.Core.Flow.Transform.Schedule - (scheduleProcess) -where -import DDC.Core.Flow.Transform.Schedule.SeriesEnv -import DDC.Core.Flow.Transform.Schedule.Nest -import DDC.Core.Flow.Procedure -import DDC.Core.Flow.Process -import DDC.Core.Flow.Compounds -import DDC.Core.Flow.Prim -import DDC.Core.Flow.Exp -import DDC.Base.Pretty -import Control.Monad - - --- | Create loops from a list of operators. --- --- * The input series must all have the same rate. --- -scheduleProcess :: Process -> Procedure -scheduleProcess - (Process - { processName = name - , processParamTypes = psType - , processParamValues = psValue - , processContexts = contexts - , processOperators = ops - , processStmts = stmts - , processResultType = tResult - , processResult = xResult}) - = let - -- Create all the contexts, starting with an empty loop nest. - Just nest1 = foldM insertContext NestEmpty contexts - - -- Schedule the series operators into the nest. - nest2 = scheduleOperators nest1 emptySeriesEnv ops - - in Procedure - { procedureName = name - , procedureParamTypes = psType - , procedureParamValues = psValue - , procedureNest = nest2 - , procedureStmts = stmts - , procedureResultType = tResult - , procedureResult = xResult } - - -------------------------------------------------------------------------------- --- | Schedule some series operators into a loop nest. -scheduleOperators - :: Nest -- ^ The starting loop nest. - -> SeriesEnv -- ^ Series environment maps series binds to elem binds. - -> [Operator] -- ^ The operators to schedule. - -> Nest - -scheduleOperators nest0 env ops - = case ops of - [] -> nest0 - op : ops' - -> let (env', nest') = scheduleOperator nest0 env op - in scheduleOperators nest' env' ops' - - --- | Schedule a single series operator into a loop nest. -scheduleOperator - :: Nest -- ^ The current loop nest - -> SeriesEnv -- ^ Series environment maps series binds to elem binds. - -> Operator -- ^ Operator to schedule. - -> (SeriesEnv, Nest) - -scheduleOperator nest0 env op - - -- Id ------------------------------------------- - | OpId{} <- op - = let - -- Get binders for the input elements. - Just nSeries - = takeNameOfBound (opInputSeries op) - - (uInput, env1, nest1) - = bindNextElem nSeries - (opInputRate op) (opElemType op) - env nest0 - - Just bResultElem - = elemBindOfSeriesBind $ opResultSeries op - - context = ContextRate (opInputRate op) - - Just nest2 = insertBody nest1 context - $ [ BodyStmt bResultElem (XVar uInput) ] - - in (env1, nest2) - - - -- Create --------------------------------------- - | OpCreate{} <- op - = let - -- Get binders for the input elements. - Just nSeries - = takeNameOfBound (opInputSeries op) - - (uInput, env1, nest1) - = bindNextElem nSeries - (opInputRate op) (opElemType op) - env nest0 - - -- Insert statements that allocate the vector. - -- We use the type-level series rate to describe the length of - -- the vector. This will be repalced by a RateNat value during - -- the concretization phase. - BName nVec _ = opResultVector op - context = ContextRate (opInputRate op) - - -- Rate we're using to allocate the result vector. - -- This will be larger than the actual result series rate if we're - -- creating a vector inside a selector context. - Just tRateAlloc = opAllocRate op - - Just nest2 = insertStarts nest1 context - $ [ StartVecNew - nVec -- allocated vector - (opElemType op) -- elem type - tRateAlloc ] -- allocation rate - - -- Insert statements that write the current element to the vector. - Just nest3 = insertBody nest2 context - $ [ BodyVecWrite - nVec -- destination vector - (opElemType op) -- elem type - (XVar (UIx 0)) -- index - (XVar uInput) ] -- value - - -- Slice the vector at the end - Just nest4 = insertEnds nest3 context - $ [ EndVecSlice - nVec -- destination vector - (opElemType op) -- elem type - (opInputRate op) ] -- index - - -- But only slice it if the input rate is different to output rate - nest' = if opInputRate op == tRateAlloc - then nest3 - else nest4 - in (env1, nest') - - - -- Maps ----------------------------------------- - | OpMap{} <- op - = let - -- Get binders for the input elements. - Just nsSeries = sequence $ map takeNameOfBound $ opInputSeriess op - tsRate = repeat (opInputRate op) - tsElem = map typeOfBind $ opWorkerParams op - - (usInputs, env1, nest1) - = bindNextElems (zip3 nsSeries tsRate tsElem) env nest0 - - -- Variables for all the input elements. - xsInputs = map XVar usInputs - - -- Substitute input element vars into the worker body. - xBody = foldl (\x (b, p) -> XApp (XLam b x) p) - (opWorkerBody op) - (zip (opWorkerParams op) xsInputs) - - -- Binder for a single result element in the series context. - Just nResultSeries = takeNameOfBind $ opResultSeries op - nResultElem = NameVarMod nResultSeries "elem" - uResultElem = UName nResultElem - - Just bResultElem = elemBindOfSeriesBind (opResultSeries op) - - -- Insert the expression that computes the new result into the nest. - context = ContextRate $ opInputRate op - Just nest2 = insertBody nest1 context - $ [ BodyStmt bResultElem xBody ] - - -- Associate the variable for the result element with the result series. - env2 = insertElemForSeries nResultSeries uResultElem env1 - - in (env2, nest2) - - - -- Folds --------------------------------------- - | OpFold{} <- op - = let - -- Lookup binders for the input elements. - Just nSeries = takeNameOfBound (opInputSeries op) - tRate = opInputRate op - tInputElem = typeOfBind (opWorkerParamElem op) - (uInput, env1, nest1) - = bindNextElem nSeries tRate tInputElem env nest0 - - -- Make a name for the accumulator. - BName nResult _ = opResultValue op - nAcc = NameVarMod nResult "acc" - - -- Type of the accumulator. - tAcc = typeOfBind (opWorkerParamAcc op) - - -- Insert statements that initialize the starting value - -- of the accumulator. - context = ContextRate $ opInputRate op - Just nest2 = insertStarts nest1 context - $ [ StartAcc nAcc tAcc (opZero op) ] - - -- Substitute input and accumulator vars into worker body. - xBody = XApp (XApp ( XLam (opWorkerParamElem op) - $ XLam (opWorkerParamIndex op) - (opWorkerBody op)) - (XVar uInput)) - (XVar (UIx 0)) - - -- Insert statements that update the accumulator - -- into the loop body. - Just nest3 = insertBody nest2 context - $ [ BodyAccRead nAcc tAcc (opWorkerParamAcc op) - , BodyAccWrite nAcc tAcc xBody ] - - -- Insert statements that read back the final value - -- after the loop has finished. - Just nest4 = insertEnds nest3 context - $ [ EndAcc nResult tAcc nAcc ] - in (env1, nest4) - - - -- Pack ---------------------------------------- - | OpPack{} <- op - = let - -- Lookup binder for the input element. - Just nSeries = takeNameOfBound (opInputSeries op) - tRate = opInputRate op - tInputElem = opElemType op - (uInput, env1, nest1) - = bindNextElem nSeries tRate tInputElem env nest0 - - -- Associate the variable for the result element with the result - -- series. We could instead add an explicit binding, but it's - -- easier just to insert an entry into the series environment. - Just nResultSeries = takeNameOfBind (opResultSeries op) - env2 = insertElemForSeries nResultSeries uInput env1 - - in (env2, nest1) + ( scheduleScalar - | otherwise - = error $ renderIndent - $ vcat [ text "ddc-core-flow.scheduleOperator" - , indent 4 $ text "Can't schedule operator." - , indent 4 $ ppr op ] + -- * Scheduling process kernels + , scheduleKernel + , Error (..) + , Lifting (..)) +where +import DDC.Core.Flow.Transform.Schedule.Kernel +import DDC.Core.Flow.Transform.Schedule.Scalar diff --git a/DDC/Core/Flow/Transform/Schedule/Base.hs b/DDC/Core/Flow/Transform/Schedule/Base.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Schedule/Base.hs @@ -0,0 +1,108 @@ + +module DDC.Core.Flow.Transform.Schedule.Base + ( elemBindOfSeriesBind + , elemBoundOfSeriesBound + , elemTypeOfSeriesType + , resultRateTypeOfSeriesType + , procTypeOfSeriesType + + , rateTypeOfRateVecType + + , elemTypeOfVectorType + , bufOfVectorName) +where +import DDC.Core.Flow.Compounds +import DDC.Core.Flow.Prim +import DDC.Core.Flow.Exp + + +-- | 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, [_tP, _tK, tE]) <- takeTyConApps tSeries' + = Just tE + + | otherwise + = Nothing + + +-- | Given the type of a series like @Series p k l e@, produce the type +-- of the result rate, namely the @k@. +resultRateTypeOfSeriesType :: TypeF -> Maybe TypeF +resultRateTypeOfSeriesType tSeries' + | isSeriesType tSeries' + , Just (_tcSeries, [_tP, tK, _tE]) <- takeTyConApps tSeries' + = Just tK + + | otherwise + = Nothing + +-- | Given the type of a series like @Series p k l e@, produce the type +-- of the process, namely the @p@ +procTypeOfSeriesType :: TypeF -> Maybe TypeF +procTypeOfSeriesType tSeries' + | isSeriesType tSeries' + , Just (_tcSeries, [tP, _tK, _tE]) <- takeTyConApps tSeries' + = Just tP + + | otherwise + = Nothing + + +-- | Given the type of a rate-annotated vector like @RateVec k e@, produce the type +-- of the rate, namely the @k@. +rateTypeOfRateVecType :: TypeF -> Maybe TypeF +rateTypeOfRateVecType tV' + | isRateVecType tV' + , Just (_tcV, [tK, _tE]) <- takeTyConApps tV' + = Just tK + + | otherwise + = Nothing + + + + +-- Vector --------------------------------------------------------------------- +-- | Given the type of a vector like @Vector k e@, produce the type +-- of a single element, namely the @e@. +elemTypeOfVectorType :: TypeF -> Maybe TypeF +elemTypeOfVectorType tVector' + | Just (_tcVector, [tE]) <- takeTyConApps tVector' + = Just tE + + | otherwise + = Nothing + +-- | Given the name of a vector, find the name of the binding of its underlying buffer. +-- This binding is produced by Extract. +bufOfVectorName :: BoundF -> BoundF +bufOfVectorName (UName n) = UName $ NameVarMod n "buf" +bufOfVectorName b = error (show b) + diff --git a/DDC/Core/Flow/Transform/Schedule/Error.hs b/DDC/Core/Flow/Transform/Schedule/Error.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Schedule/Error.hs @@ -0,0 +1,75 @@ + +module DDC.Core.Flow.Transform.Schedule.Error + (Error (..)) +where +import DDC.Core.Flow.Exp +import DDC.Core.Flow.Prim +import DDC.Core.Flow.Process.Operator +import DDC.Core.Flow.Transform.Annotate +import DDC.Core.Pretty +import qualified DDC.Core.Flow.Transform.Slurp.Error as Slurp + + +-- | Reason a process kernel could not be scheduled into a procedure. +data Error + -- | Process has no rate parameters. + = ErrorNoRateParameters + + -- | Process has series of different rates, + -- but all series must have the same rate. + | ErrorMultipleRates + + -- | Primary rate variable of the process does not match + -- the rate of the paramter series. + | ErrorPrimaryRateMismatch + + -- | Cannot lift expression to vector operators. + | ErrorCannotLiftExp (Exp () Name) + + -- | Cannot lift type to vector type. + | ErrorCannotLiftType (Type Name) + + -- | Current scheduler does not support this operator. + | ErrorUnsupported Operator + + -- | Multiple fills to the same output, in "interfering contexts" (eg same branch of an append) + | ErrorMultipleFills + + -- | Cannot slurp process description from one of the top-level + -- declarations. + | ErrorSlurpError Slurp.Error + deriving Show + + +instance Pretty Error where + ppr err + = case err of + ErrorNoRateParameters + -> vcat [ text "Series process has no rate parameters." ] + + ErrorMultipleRates + -> vcat [ text "Series process has multiple rate parameters."] + + ErrorPrimaryRateMismatch + -> vcat [ text "Series process primary rate mismatch."] + + ErrorCannotLiftExp x + -> vcat [ text "Cannot lift expression in series process." + , empty + , indent 4 $ ppr (annotate () x) ] + + ErrorCannotLiftType t + -> vcat [ text "Cannot lift type in series process." + , empty + , indent 4 $ ppr t ] + + ErrorUnsupported _ + -> vcat [ text "Cannot lower series operator with this method."] + + ErrorMultipleFills + -> vcat [ text "Multiple fills to the same output, in 'interfering contexts' (eg same branch of an append)" ] + + ErrorSlurpError errSlurp + -> vcat [ text "Error slurping series process." + , indent 2 $ ppr errSlurp ] + diff --git a/DDC/Core/Flow/Transform/Schedule/Kernel.hs b/DDC/Core/Flow/Transform/Schedule/Kernel.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Schedule/Kernel.hs @@ -0,0 +1,320 @@ + +module DDC.Core.Flow.Transform.Schedule.Kernel + ( scheduleKernel + , Error (..) + , Lifting (..)) +where +import DDC.Core.Flow.Transform.Schedule.Nest +import DDC.Core.Flow.Transform.Schedule.Error +import DDC.Core.Flow.Transform.Schedule.Lifting +import DDC.Core.Flow.Transform.Schedule.Base +import DDC.Core.Flow.Process +import DDC.Core.Flow.Procedure +import DDC.Core.Flow.Compounds +import DDC.Core.Flow.Exp +import DDC.Core.Flow.Prim +import DDC.Core.Flow.Context + + +-- | Schedule a process kernel into a procedure. +-- +-- A process kernel is a process with the following restricitions: +-- 1) All input series have the same rate. +-- 2) A kernel accumulates data into sinks, rather than allocating new values. +-- 3) A kernel can be scheduled into a single loop. +-- +--- The process kernel scheduler can produce code for +-- map, reduce, fill, gather, scatter +-- +-- But not +-- fold -- use reduce instead. +-- create -- use fill instead. +-- pack -- we don't support SIMD masks. +-- +scheduleKernel :: Lifting -> Process -> Either Error Procedure +scheduleKernel + lifting + (Process { processName = name + , processParamFlags = bsParams + , processContext = context }) + = do + -- Lower rates of RateVec parameters. + -- We also keep a copy of the original RateVec, + -- in case it is used by a cross or a gather. + let bsParams_lowered + = map (\(flag, BName n t) + -> if not flag + then case lowerSeriesRate lifting t of + Just t' + -> (flag, BName n t') + Nothing + -> (flag, BName n t) + else (flag, BName n t)) + $ bsParams + + let bsParamValues + = map snd + $ filter (not.fst) + $ bsParams + + let c = liftingFactor lifting + + let frate r _ = return $ tDown c r + let fop = scheduleOperator lifting bsParamValues + + nest <- scheduleContext frate fop context + + return $ Procedure + { procedureName = name + , procedureParamFlags = bsParams_lowered + , procedureNest = nest } + + +------------------------------------------------------------------------------- +-- | Schedule a single series operator into a loop nest. +scheduleOperator + :: Lifting + -> ScalarEnv + -> FillMap -- ^ Map of which operators use which write-to accs + -> Operator -- ^ The operator to schedule. + -> Either Error ([StmtStart], [StmtBody], [StmtEnd]) + +scheduleOperator lifting envScalar fills op + -- Id ------------------------------------------- + | OpId{} <- op + = do -- Get binders for the input elements. + let Just bResult = elemBindOfSeriesBind (opResultSeries op) + >>= liftTypeOfBind lifting + let Just uInput = elemBoundOfSeriesBound (opInputSeries op) + + return ( [] + , [ BodyStmt bResult (XVar uInput) ] + , [] ) + + | OpSeriesOfArgument{} <- op + = do let c = liftingFactor lifting + let tK = opInputRate op + let tA = opElemType op + let BName n t = opResultSeries op + let Just t' = lowerSeriesRate lifting t + let bS = BName n t' + let Just uS = takeSubstBoundOfBind bS + let Just tP = procTypeOfSeriesType (typeOfBind bS) + let Just bResult = elemBindOfSeriesBind bS + >>= liftTypeOfBind lifting + + -- Body expressions that take the next element from each input series. + let bodies + = [ BodyStmt bResult + (xNextC c tP tK tA (XVar uS) (XVar (UIx 0))) ] + + return ( [] + , bodies + , [] ) + + -- Map ----------------------------------------- + | OpMap{} <- op + = do -- Bind for the result element. + let Just bResultE = elemBindOfSeriesBind (opResultSeries op) + >>= liftTypeOfBind lifting + + -- Bounds for all the input series. + let Just usInput = sequence + $ map elemBoundOfSeriesBound + $ opInputSeriess op + + -- Bounds for the worker parameters, along with the lifted versions. + let bsParam = opWorkerParams op + bsParam_lifted <- mapM (liftTypeOfBindM lifting) bsParam + let envLift = zip bsParam bsParam_lifted + + xWorker_lifted <- liftWorker lifting envScalar envLift + $ opWorkerBody op + + -- Expression to apply the inputs to the worker. + let xBody = foldl (\x (b, p) -> XApp (XLam b x) p) + (xWorker_lifted) + [(b, XVar u) + | b <- bsParam_lifted + | u <- usInput ] + + let bodies = [ BodyStmt bResultE xBody ] + + return ([], bodies, []) + + -- Fill ---------------------------------------- + | OpFill{} <- op + = do let c = liftingFactor lifting + + -- Bound for input element. + let Just uInput = elemBoundOfSeriesBound + $ opInputSeries op + + let UName nVec = opTargetVector op + let index + | Just n <- getAcc fills nVec + = xRead tNat + $ XVar $ UName $ NameVarMod n "count" + | otherwise + = XVar $ UIx 0 + + -- Write to target vector. + let bodies = [ BodyStmt (BNone tUnit) + (xWriteVectorC c + (opElemType op) + (XVar $ bufOfVectorName $ opTargetVector op) + index + (XVar $ uInput)) ] + + return ([], bodies, []) + + -- Reduce -------------------------------------- + | OpReduce{} <- op + = do let c = liftingFactor lifting + let tA = typeOfBind $ opWorkerParamElem op + + -- Evaluate the zero value and initialize the vector accumulator. + let UName nRef = opTargetRef op + let nAccZero = NameVarMod nRef "zero" + let bAccZero = BName nAccZero tA + let uAccZero = UName nAccZero + + let nAccVec = NameVarMod nRef "vec" + let uAccVec = UName nAccVec + + let starts + = [ StartStmt bAccZero (opZero op) + , StartAcc nAccVec + (tVec c tA) + (xvRep c tA (XVar uAccZero)) ] + + -- Bound for input element. + let Just uInput = elemBoundOfSeriesBound + $ opInputSeries op + + -- Bound for intermediate accumulator value. + let nAccVal = NameVarMod nRef "val" + let uAccVal = UName nAccVal + let bAccVal = BName nAccVal (tVec c tA) + + -- Lift the worker function. + let bsParam = [ opWorkerParamAcc op, opWorkerParamElem op ] + bsParam_lifted <- mapM (liftTypeOfBindM lifting) bsParam + let envLift = zip bsParam bsParam_lifted + + xWorker_lifted <- liftWorker lifting envScalar envLift + $ opWorkerBody op + + -- Read the current accumulator value and update it with the worker. + let xBody_lifted x1 x2 + = XApp (XApp ( XLam (opWorkerParamAcc op) + $ XLam (opWorkerParamElem op) + (xWorker_lifted)) + x1) + x2 + + let bodies + = [ BodyAccRead nAccVec (tVec c tA) bAccVal + , BodyAccWrite nAccVec (tVec c tA) + (xBody_lifted (XVar uAccVal) (XVar uInput)) ] + + -- Read back the vector accumulator and to a final fold over its parts. + let nAccResult = NameVarMod nRef "res" + let bAccResult = BName nAccResult (tVec c tA) + let uAccResult = UName nAccResult + let bPart (i :: Int) = BName (NameVarMod nAccResult (show i)) tA + let uPart (i :: Int) = UName (NameVarMod nAccResult (show i)) + + let nAccInit = NameVarMod nRef "init" + + let xBody x1 x2 + = XApp (XApp ( XLam (opWorkerParamAcc op) + $ XLam (opWorkerParamElem op) + (opWorkerBody op)) + x1) + x2 + + let ends + = [ EndStmt bAccResult + (xRead (tVec c tA) (XVar uAccVec)) + + , EndStmt (BName nAccInit tA) + (xRead tA (XVar $ opTargetRef op)) ] + + ++ [ EndStmt (bPart 0) + (xBody (XVar $ UName nAccInit) + (xvProj c 0 tA (XVar uAccResult))) ] + + ++ [ EndStmt (bPart i) + (xBody (XVar (uPart (i - 1))) + (xvProj c i tA (XVar uAccResult))) + | i <- [1.. c - 1]] + -- Write final value to destination. + ++ [ EndStmt (BNone tUnit) + (xWrite tA (XVar $ opTargetRef op) + (XVar $ uPart (c - 1))) ] + -- Bind final unit value. + ++ [ EndStmt (opResultBind op) + xUnit ] + + + return (starts, bodies, ends) + + + -- Gather -------------------------------------- + | OpGather{} <- op + = do + let c = liftingFactor lifting + + -- Bind for result element. + let Just bResultE = elemBindOfSeriesBind (opResultBind op) + >>= liftTypeOfBind lifting + + -- Bound of source index. + let Just uIndex = elemBoundOfSeriesBound (opSourceIndices op) + + -- Read from vector. + let bodies = [ BodyStmt bResultE + (xvGather c + (opVectorRate op) + (opElemType op) + (XVar $ opSourceVector op) + (XVar $ uIndex)) ] + + return ([], bodies, []) + + -- Scatter ------------------------------------- + | OpScatter{} <- op + = do + let c = liftingFactor lifting + + -- Bound of source index. + let Just uIndex = elemBoundOfSeriesBound (opSourceIndices op) + + -- Bound of source elements. + let Just uElem = elemBoundOfSeriesBound (opSourceElems op) + + -- Read from vector. + let bodies = [ BodyStmt (BNone tUnit) + (xvScatter c + (opElemType op) + (XVar $ opTargetVector op) + (XVar $ uIndex) (XVar $ uElem)) ] + + -- Bind final unit value. + let ends = [ EndStmt (opResultBind op) + xUnit ] + + return ([], bodies, ends) + + -- Unsupported --------------------------------- + | otherwise + = Left $ ErrorUnsupported op + + +liftTypeOfBindM :: Lifting -> Bind Name -> Either Error (Bind Name) +liftTypeOfBindM lifting b + = case liftTypeOfBind lifting b of + Just b' -> return b' + _ -> Left $ ErrorCannotLiftType (typeOfBind b) + diff --git a/DDC/Core/Flow/Transform/Schedule/Lifting.hs b/DDC/Core/Flow/Transform/Schedule/Lifting.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Schedule/Lifting.hs @@ -0,0 +1,130 @@ + +module DDC.Core.Flow.Transform.Schedule.Lifting + ( Lifting (..) + , ScalarEnv + , LiftEnv + + -- * Lifting Types + , liftType + , liftTypeOfBind + , liftWorker + + -- * Lowering Types + , lowerSeriesRate) +where +import DDC.Core.Flow.Transform.Schedule.Error +import DDC.Core.Flow.Compounds +import DDC.Core.Flow.Exp +import DDC.Core.Flow.Prim +import Control.Monad +import Data.List + + +-- | Lifting config controls how many elements should be processed +-- per loop iteration. +data Lifting + = Lifting + { -- How many elements to process for each loop iteration. + liftingFactor :: Int } + deriving (Eq, Show) + + +-- | Scalar values in scope. +type ScalarEnv + = [BindF] + +-- | Map original variable to lifted version. +type LiftEnv + = [(BindF, BindF)] + + +-- | Try to lift the given type. +liftType :: Lifting -> TypeF -> Maybe TypeF +liftType l tt + | liftingFactor l == 1 + = Just tt + + | elem tt + [ tFloat 32, tFloat 64 + , tWord 8, tWord 16, tWord 32, tWord 64 + , tInt + , tNat ] + + = Just (tVec (liftingFactor l) tt) + + | otherwise + = Nothing + + +-- | Try to lift the type of a binder. +liftTypeOfBind :: Lifting -> BindF -> Maybe BindF +liftTypeOfBind l b + = case b of + BName n t -> liftM (BName n) (liftType l t) + BAnon t -> liftM BAnon (liftType l t) + BNone t -> liftM BNone (liftType l t) + + +-- | Try to lift a first-order worker expression to so it operates on elements +-- of vec type instead of scalars. +liftWorker :: Lifting -> ScalarEnv -> LiftEnv -> ExpF -> Either Error ExpF +liftWorker lifting envScalar envLift xx + = let down = liftWorker lifting envScalar envLift + in case xx of + XVar u + -- Replace vars by their vector version. + | Just (_, bL) <- find (\(bS', _) -> boundMatchesBind u bS') envLift + , Just uL <- takeSubstBoundOfBind bL + -> Right (XVar uL) + + -- Replicate scalar vars. + -- ISSUE #328: Element type for rep opretora is hard coded to Float32 + | any (boundMatchesBind u) envScalar + , nPrim <- PrimVecRep (liftingFactor lifting) + , tPrim <- typePrimVec nPrim + -> Right $ XApp (XApp (XVar (UPrim (NamePrimVec nPrim) tPrim)) + (XType $ tFloat 32)) + xx + + -- Replicate literals. + -- ISSUE #328: Element type for rep opretora is hard coded to Float32 + XCon dc + | DaConPrim (NameLitFloat _ 32) _ + <- dc + , nPrim <- PrimVecRep (liftingFactor lifting) + , tPrim <- typePrimVec nPrim + -> Right $ XApp (XApp (XVar (UPrim (NamePrimVec nPrim) tPrim)) + (XType $ tFloat 32)) + xx + + -- Replace scalar primops by vector versions. + XApp (XVar (UPrim (NamePrimArith prim) _)) (XType tElem) + | Just prim' <- liftPrimArithToVec (liftingFactor lifting) prim + -> Right $ XApp (XVar (UPrim (NamePrimVec prim') (typePrimVec prim'))) + (XType tElem) + + + -- Boiler plate application. + XApp x1 x2 + -> do x1' <- down x1 + x2' <- down x2 + return $ XApp x1' x2' + + + _ -> Left (ErrorCannotLiftExp xx) + + +-- Down ----------------------------------------------------------------------- +-- | Lower the rate of a series, +-- to account for lifting of the code that consumes it. +lowerSeriesRate :: Lifting -> TypeF -> Maybe TypeF +lowerSeriesRate lifting tt + | Just (NameTyConFlow TyConFlowSeries, [tP, tK, tA]) + <- takePrimTyConApps tt + , c <- liftingFactor lifting + = Just (tSeries tP (tDown c tK) tA) + + + | otherwise + = Nothing + diff --git a/DDC/Core/Flow/Transform/Schedule/Nest.hs b/DDC/Core/Flow/Transform/Schedule/Nest.hs --- a/DDC/Core/Flow/Transform/Schedule/Nest.hs +++ b/DDC/Core/Flow/Transform/Schedule/Nest.hs @@ -1,177 +1,183 @@ module DDC.Core.Flow.Transform.Schedule.Nest - ( insertContext - , insertStarts - , insertBody - , insertEnds) + ( -- * Insertion into a loop nest + scheduleContext + ) where import DDC.Core.Flow.Procedure -import DDC.Core.Flow.Compounds -import DDC.Core.Flow.Prim +import DDC.Core.Flow.Process import DDC.Core.Flow.Exp -import Data.Monoid +import DDC.Core.Flow.Transform.Schedule.Error +import DDC.Core.Flow.Prim +import DDC.Core.Flow.Compounds +import DDC.Core.Flow.Context +import Control.Arrow +import qualified Data.Map as Map -------------------------------------------------------------------------------- --- | 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 +scheduleContext + :: (Type Name -> Context -> Either Error (Type Name)) + -> (FillMap -> Operator -> Either Error ([StmtStart], [StmtBody], [StmtEnd])) + -> Context + -> Either Error Nest --- Loop context at top level. -insertContext NestEmpty context@ContextRate{} - = Just $ nestOfContext context +scheduleContext frate fop topctx + = do fills <- maybe (Left ErrorMultipleFills) Right + $ pathsOfFills topctx --- 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 } + let (starts', ends') = allocAndTrunc fills --- 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 } + (starts, nest, ends) <- go topctx + + return $ insertStarts (starts' ++ starts) + $ insertEnds (ends' ++ ends) + $ nest + where + fop' op + = do fills <- maybe (Left ErrorMultipleFills) Right + $ pathsOfFills topctx + fop fills op --- Nested selector context inside selector context. -insertContext nest@NestIf{} context@ContextSelect{} - | nestInnerRate nest == contextOuterRate context - = Just $ nest { nestInner = nestInner nest <> nestOfContext context } + go ctx + = case ctx of + ContextRate{} + -> do (s1,bodies,e1) <- ops ctx + (s2,i2, e2) <- inner ctx + rate' <- frate (contextRate ctx) ctx -insertContext _nest _context - = Nothing + let nest = NestLoop + { nestRate = rate' + , nestStart = [] + , nestBody = bodies + , nestInner = i2 + , nestEnd = [] } + return ( s1 ++ s2 + , nest + , e1 ++ e2) --- | 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{} + -> do (s1,bodies,e1) <- ops ctx + (s2,i2, e2) <- inner ctx - ContextSelect{} - -> NestIf - { nestOuterRate = contextOuterRate context - , nestInnerRate = contextInnerRate context - , nestFlags = contextFlags context - , nestBody = [] - , nestInner = NestEmpty } + rateOuter <- frate (contextOuterRate ctx) ctx + rateInner <- frate (contextInnerRate ctx) ctx + let nest = NestGuard + { nestOuterRate = rateOuter + , nestInnerRate = rateInner + , nestFlags = contextFlags ctx + , nestBody = bodies + , nestInner = i2 } --- | 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 + return ( s1 ++ s2 + , nest + , e1 ++ e2) - NestList ns - -> any (flip nestContainsRate tRate) ns - NestLoop{} - -> nestRate nest == tRate - || nestContainsRate (nestInner nest) tRate + ContextSegment{} + -> do (s1,bodies,e1) <- ops ctx + (s2,i2, e2) <- inner ctx - NestIf{} - -> nestInnerRate nest == tRate - || nestContainsRate (nestInner nest) tRate + rateOuter <- frate (contextOuterRate ctx) ctx + rateInner <- frate (contextInnerRate ctx) ctx --- | 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 }] + let nest = NestSegment + { nestOuterRate = rateOuter + , nestInnerRate = rateInner + , nestLength = contextLens ctx + , nestBody = bodies + , nestInner = i2 } + return ( s1 ++ s2 + , nest + , e1 ++ e2) -------------------------------------------------------------------------------- --- | Insert starting statements in the given context. -insertStarts :: Nest -> Context -> [StmtStart] -> Maybe Nest + ContextAppend{} + -> do (s1,i1,e1) <- go (contextInner1 ctx) + (s2,i2,e2) <- go (contextInner2 ctx) --- The starts are for this loop. -insertStarts nest@NestLoop{} (ContextRate tRate) starts' - | tRate == nestRate nest - = Just $ nest { nestStart = nestStart nest ++ starts' } + let nest = NestList + [ i1, i2 ] --- 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' } + return ( s1 ++ s2 + , nest + , e1 ++ e2) -insertStarts _ _ _ - = Nothing -------------------------------------------------------------------------------- --- | Insert starting statements in the given context. -insertBody :: Nest -> Context -> [StmtBody] -> Maybe Nest + ops ctx + = do outs <- mapM fop' (contextOps ctx) + let (ss,bs,es) = unzip3 outs + return (concat ss, concat bs, concat es) -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' } + inner ctx + = do outs <- mapM go (contextInner ctx) + let (ss,ins,es) = unzip3 outs + return (concat ss, listNest ins, concat es) - -- Try and insert them in an inner context. - | Just inner' <- insertBody (nestInner nest) context body' - = Just $ nest { nestInner = inner' } + listNest [] + = NestEmpty + listNest [n] + = n + listNest ns + = NestList ns -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' } +allocAndTrunc :: FillMap -> ([StmtStart], [StmtEnd]) +allocAndTrunc fills + = concat *** concat + $ unzip + $ map go + $ Map.toList fills + where + go (k,(f,t)) + | isSimple f || isNone f + = ([], []) + | otherwise + = let k' = getAccForPath fills f + kk = maybe k id k' + co = NameVarMod kk "count" -insertBody (NestList (n:ns)) context body' - | Just n' <- insertBody n context body' - = Just $ NestList (n':ns) + s | k == kk + = [StartAcc + { startAccName = co + , startAccType = tNat + , startAccExp = xNat 0 } ] + | otherwise + = [] -insertBody (NestList (n:ns)) context body' - | Just (NestList ns') <- insertBody (NestList ns) context body' - = Just $ NestList (n:ns') + e = [EndVecTrunc + k t + (UName co) ] -insertBody (NestList []) _ _ - = Nothing - -insertBody _ _ _ - = Nothing + in (s, e) ------------------------------------------------------------------------------- --- | 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' } +-- | Insert starting statements in the given context. +insertStarts :: [StmtStart] -> Nest -> Nest +insertStarts starts' nest + = case nest of + NestList (n:ns) + -> NestList (insertStarts starts' n : ns) + NestLoop{} + -> nest { nestStart = nestStart nest ++ starts' } + _ + -> nest --- 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 +------------------------------------------------------------------------------- +-- | Insert ends statements in the given context. +insertEnds :: [StmtEnd] -> Nest -> Nest +insertEnds ends' nest + = case nest of + NestList ns + | (r:rs) <- reverse ns + -> NestList (reverse rs ++ [insertEnds ends' r]) + NestLoop{} + -> nest { nestEnd = nestEnd nest ++ ends' } + _ + -> nest diff --git a/DDC/Core/Flow/Transform/Schedule/Scalar.hs b/DDC/Core/Flow/Transform/Schedule/Scalar.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Schedule/Scalar.hs @@ -0,0 +1,330 @@ + +module DDC.Core.Flow.Transform.Schedule.Scalar + (scheduleScalar) +where +import DDC.Core.Flow.Transform.Schedule.Nest +import DDC.Core.Flow.Transform.Schedule.Error +import DDC.Core.Flow.Transform.Schedule.Base +import DDC.Core.Flow.Procedure +import DDC.Core.Flow.Process +import DDC.Core.Flow.Compounds +import DDC.Core.Flow.Prim +import DDC.Core.Flow.Prim.OpStore +import DDC.Core.Flow.Exp +import DDC.Core.Flow.Context + + +-- | Schedule a process into a procedure, producing scalar code. +scheduleScalar :: Process -> Either Error Procedure +scheduleScalar + (Process { processName = name + , processParamFlags = bsParams + , processContext = context }) + = do + nest <- scheduleContext (\r _ -> return r) + (scheduleOperator context) context + + return $ Procedure + { procedureName = name + , procedureParamFlags = bsParams + , procedureNest = nest } + + +------------------------------------------------------------------------------- +-- | Schedule a single series operator into a loop nest. +scheduleOperator + :: Context -- ^ Context of all operators + -> FillMap -- ^ Map of which operators use which write-to accs + -> Operator -- ^ Operator to schedule. + -> Either Error ([StmtStart], [StmtBody], [StmtEnd]) + +scheduleOperator _ctx fills op + + -- Id ------------------------------------------- + | OpId{} <- op + = do -- Get binders for the input elements. + let Just bResult = elemBindOfSeriesBind (opResultSeries op) + let Just uInput = elemBoundOfSeriesBound (opInputSeries op) + + return ( [] + , [ BodyStmt bResult (XVar uInput) ] + , [] ) + + | OpSeriesOfRateVec{} <- op + = do let tK = opInputRate op + let tA = opElemType op + let bS = opResultSeries op + let uInput = opInputRateVec op + let Just uS = takeSubstBoundOfBind bS + let Just tP = procTypeOfSeriesType (typeOfBind bS) + let Just bResult = elemBindOfSeriesBind bS + + -- Convert the RateVec to a series + let starts + = [ StartStmt bS + (xSeriesOfRateVec tP tK tA (XVar uInput)) ] + + -- Body expressions that take the next element from each input series. + let bodies + = [ BodyStmt bResult + (xNext tP tK tA (XVar uS) (XVar (UIx 0))) ] + + return ( starts + , bodies + , [] ) + + + | OpSeriesOfArgument{} <- op + = do let tK = opInputRate op + let tA = opElemType op + let bS = opResultSeries op + let Just uS = takeSubstBoundOfBind bS + let Just tP = procTypeOfSeriesType (typeOfBind bS) + let Just bResult = elemBindOfSeriesBind bS + + -- Body expressions that take the next element from each input series. + -- Could be different to RateVec above, since could be from other source? + let bodies + = [ BodyStmt bResult + (xNext tP tK tA (XVar uS) (XVar (UIx 0))) ] + + return ( [] + , bodies + , [] ) + + + -- Rep ----------------------------------------- + | OpRep{} <- op + = do -- Make a binder for the replicated element. + let BName nResult _ = opResultSeries op + let nVal = NameVarMod nResult "val" + let uVal = UName nVal + let bVal = BName nVal (opElemType op) + + -- Get the binder for the use of it in the replicated context. + let Just bResult = elemBindOfSeriesBind (opResultSeries op) + + -- Evaluate the expression to be replicated once, + -- before the main loop. + let starts + = [ StartStmt bVal (opInputExp op) ] + + -- Use the expression for each iteration of the loop. + let bodies + = [ BodyStmt bResult (XVar uVal) ] + + return (starts, bodies, []) + + -- Reps ---------------------------------------- + | OpReps{} <- op + = do -- Lookup binder for the input element. + let Just uInput = elemBoundOfSeriesBound (opInputSeries op) + + -- Set the result to point to the input element. + let Just bResult = elemBindOfSeriesBind (opResultSeries op) + + let bodies + = [ BodyStmt bResult + (XVar uInput)] + + return ([], bodies, []) + + -- Indices -------------------------------------- + | OpIndices{} <- op + = do + -- In a segment context the variable ^0 is the index into + -- the current segment. + let Just bResult = elemBindOfSeriesBind (opResultSeries op) + + let bodies + = [ BodyStmt bResult + (XVar (UIx 0)) ] + + return ([], bodies, []) + + -- Fill ----------------------------------------- + | OpFill{} <- op + = do -- Get bound of the input element. + let Just uInput = elemBoundOfSeriesBound (opInputSeries op) + + -- Write the current element to the vector. + let UName nVec = opTargetVector op + + let index + | Just n <- getAcc fills nVec + = xRead tNat + $ XVar $ UName $ NameVarMod n "count" + | otherwise + = XVar $ UIx 0 + + let bodies + = [ BodyVecWrite + nVec -- destination vector + (opElemType op) -- series elem type + index -- index + (XVar uInput) ] -- value + + let inc + | Just n <- getAcc fills nVec + , n == nVec + = [ BodyAccWrite + (NameVarMod n "count") + tNat + (xIncrement index) ] + | otherwise + = [] + + return ([], bodies ++ inc, []) + + -- Gather --------------------------------------- + | OpGather{} <- op + = do -- Bind for result element. + let Just bResult = elemBindOfSeriesBind (opResultBind op) + + -- Bound of source index. + let Just uIndex = elemBoundOfSeriesBound (opSourceIndices op) + let buf = xBufOfRateVec (opVectorRate op) (opElemType op) + (XVar $ opSourceVector op) + + -- Read from the vector. + let bodies = [ BodyStmt bResult + (xReadVector + (opElemType op) + buf + (XVar $ uIndex)) ] + + return ([], bodies, []) + + -- Scatter -------------------------------------- + | OpScatter{} <- op + = do -- Bound of source index. + let Just uIndex = elemBoundOfSeriesBound (opSourceIndices op) + + -- Bound of source elements. + let Just uElem = elemBoundOfSeriesBound (opSourceElems op) + + -- Read from vector. + let bodies = [ BodyStmt (BNone tUnit) + (xWriteVector + (opElemType op) + (XVar $ bufOfVectorName $ opTargetVector op) + (XVar $ uIndex) (XVar $ uElem)) ] + + -- Bind final unit value. + let ends = [ EndStmt (opResultBind op) + xUnit ] + + return ([], bodies, ends) + + -- Maps ----------------------------------------- + | OpMap{} <- op + = do -- Bind for the result element. + let Just bResult = elemBindOfSeriesBind (opResultSeries op) + + -- Binds for all the input elements. + let Just usInput = sequence + $ map elemBoundOfSeriesBound + $ opInputSeriess op + + -- Apply input element vars into the worker body. + let xBody + = foldl (\x (b, p) -> XApp (XLam b x) p) + (opWorkerBody op) + [(b, XVar u) + | b <- opWorkerParams op + | u <- usInput ] + + let bodies + = [ BodyStmt bResult xBody ] + + return ([], bodies, []) + + -- Pack ---------------------------------------- + | OpPack{} <- op + = do -- Lookup binder for the input element. + let Just uInput = elemBoundOfSeriesBound (opInputSeries op) + + -- Set the result to point to the input element + let Just bResult = elemBindOfSeriesBind (opResultSeries op) + + let bodies + = [ BodyStmt bResult + (XVar uInput)] + + return ([], bodies, []) + + -- Generate ------------------------------------- + | OpGenerate{} <- op + = do -- Bind for the result element. + let Just bResult = elemBindOfSeriesBind (opResultSeries op) + + -- Apply loop index into the worker body. + let xBody + = XApp ( XLam (opWorkerParamIndex op) + (opWorkerBody op)) + (XVar (UIx 0)) -- index + + let bodies + = [ BodyStmt bResult xBody ] + + return ([], bodies, []) + +-- Reduce -------------------------------------- + | OpReduce{} <- op + = do -- Initialize the accumulator. + let UName nResult = opTargetRef op + let nAcc = NameVarMod nResult "acc" + let tAcc = typeOfBind (opWorkerParamAcc op) + + let nAccInit = NameVarMod nResult "init" + + let starts + = [ StartStmt (BName nAccInit tAcc) + (xRead tAcc (XVar $ opTargetRef op)) + , StartAcc nAcc tAcc (XVar (UName nAccInit)) ] + + -- Lookup binders for the input elements. + let Just uInput = elemBoundOfSeriesBound (opInputSeries op) + + -- Bind for intermediate accumulator value. + let nAccVal = NameVarMod nResult "val" + let uAccVal = UName nAccVal + let bAccVal = BName nAccVal tAcc + + -- Substitute input and accumulator vars into worker body. + let xBody x1 x2 + = XApp (XApp ( XLam (opWorkerParamAcc op) + $ XLam (opWorkerParamElem op) + (opWorkerBody op)) + x1) + x2 + + -- Update the accumulator in the loop body. + let bodies + = [ BodyAccRead nAcc tAcc bAccVal + , BodyAccWrite nAcc tAcc + (xBody (XVar uAccVal) + (XVar uInput)) ] + + -- Read back the final value after the loop has finished and + -- write it to the destination. + let nAccRes = NameVarMod nResult "res" + let ends + = [ EndAcc nAccRes tAcc nAcc + , EndStmt (BNone tUnit) + (xWrite tAcc (XVar $ opTargetRef op) + (XVar $ UName nAccRes)) ] + + return (starts, bodies, ends) + + -- Unsupported ---------------------------------- + | otherwise + = Left $ ErrorUnsupported op + +-- | Build an expression that increments a natural. +xIncrement :: Exp a Name -> Exp a Name +xIncrement xx + = xApps (XVar (UPrim (NamePrimArith PrimArithAdd) + (typePrimArith PrimArithAdd))) + [ XType tNat, xx, XCon (dcNat 1) ] + diff --git a/DDC/Core/Flow/Transform/Schedule/SeriesEnv.hs b/DDC/Core/Flow/Transform/Schedule/SeriesEnv.hs deleted file mode 100644 --- a/DDC/Core/Flow/Transform/Schedule/SeriesEnv.hs +++ /dev/null @@ -1,157 +0,0 @@ - -module DDC.Core.Flow.Transform.Schedule.SeriesEnv - ( SeriesEnv (..) - , emptySeriesEnv - , insertElemForSeries - - , bindNextElem - , bindNextElems - - , elemBindOfSeriesBind - , elemBoundOfSeriesBound - , elemTypeOfSeriesType - , rateTypeOfSeriesType ) -where -import DDC.Core.Flow.Transform.Schedule.Nest -import DDC.Core.Flow.Procedure -import DDC.Core.Flow.Compounds -import DDC.Core.Flow.Prim -import DDC.Core.Flow.Exp -import qualified Data.Map as Map -import Data.Map (Map) - - -data SeriesEnv - = SeriesEnv - { -- | Maps the bound for a whole series to the bound for - -- a single element in the series context. - envSeriesElems :: Map Name (Bound Name) - } - - --- | An empty series environment. -emptySeriesEnv :: SeriesEnv -emptySeriesEnv - = SeriesEnv Map.empty - - --- | Insert an entry into the series environment. -insertElemForSeries - :: Name -> BoundF -> SeriesEnv -> SeriesEnv - -insertElemForSeries n u (SeriesEnv env) - = SeriesEnv (Map.insert n u env) - - --- | Produce the `Bound` that holds the next element for the given series, --- which exists in the series's context. --- --- We first try to look up the required bound from the series environment, --- if it's not already available then insert a statement into the loop nest --- to get actually get the next element from the series. -bindNextElem - :: Name -- ^ Name of series. - -> TypeF -- ^ Rate of series - -> TypeF -- ^ Series element type. - -> SeriesEnv -- ^ Current series environment. - -> Nest -- ^ Current loop nest. - -> (BoundF, SeriesEnv, Nest) - -bindNextElem nSeries tRate tElem env nest0 - -- There is already a mapping in the environment. - | Just uElem <- Map.lookup nSeries (envSeriesElems env) - = (uElem, env, nest0) - - -- Insert a statement into the loop nest to get the next element - -- from the series. - | otherwise - = let -- bound for the single element - nElem = NameVarMod nSeries "elem" - uElem = UName nElem - - -- Expression to get the next element from the series. - uSeries = UName nSeries - uIndex = UIx 0 - xGet = xNext tRate tElem (XVar uSeries) (XVar uIndex) - - -- Insert the statement into the loop nest. - Just nest1 - = (insertBody nest0 (ContextRate tRate) - [ BodyStmt (BName nElem tElem) xGet ]) - - env' = env { envSeriesElems - = Map.insert nSeries uElem - (envSeriesElems env) } - - in (uElem, env', nest1) - - --- | Like `bindNextElem`, but handle several series at once. -bindNextElems - :: [(Name, TypeF, TypeF)] - -- ^ Names, rates, and element types. - -> SeriesEnv -- ^ Current series environment. - -> Nest -- ^ Current loop nest. - -> ([BoundF], SeriesEnv, Nest) - -bindNextElems junk env nest0 - = case junk of - [] - -> ([], env, nest0) - - (nSeries, tRate, tElem) : junk' - -> let (uElem1, env1, nest1) - = bindNextElem nSeries tRate tElem env nest0 - - (uElems', env', nest') - = bindNextElems junk' env1 nest1 - - in (uElem1 : uElems', env', nest') - - --- | Given the bind of a series, produce the bound that refers to the --- next element of the series in its context. -elemBindOfSeriesBind :: BindF -> Maybe BindF -elemBindOfSeriesBind bSeries - | BName nSeries tSeries' <- bSeries - , nElem <- NameVarMod nSeries "elem" - , Just tElem <- elemTypeOfSeriesType tSeries' - = Just $ BName nElem tElem - - | otherwise - = Nothing - - --- | Given the bound of a series, produce the bound that refers to the --- next element of the series in its context. -elemBoundOfSeriesBound :: BoundF -> Maybe BoundF -elemBoundOfSeriesBound uSeries - | UName nSeries <- uSeries - , nElem <- NameVarMod nSeries "elem" - = Just $ UName nElem - - | otherwise - = Nothing - - --- | Given the type of a series like @Series k e@, produce the type --- of a single element, namely the @e@. -elemTypeOfSeriesType :: TypeF -> Maybe TypeF -elemTypeOfSeriesType tSeries' - | Just (_tcSeries, [_tK, tE]) <- takeTyConApps tSeries' - = Just tE - - | otherwise - = Nothing - - --- | Given the type of a series like @Series k e@, produce the type --- of the rate, namely the @k@. -rateTypeOfSeriesType :: TypeF -> Maybe TypeF -rateTypeOfSeriesType tSeries' - | Just (_tcSeries, [tK, _tE]) <- takeTyConApps tSeries' - = Just tK - - | otherwise - = Nothing - diff --git a/DDC/Core/Flow/Transform/Slurp.hs b/DDC/Core/Flow/Transform/Slurp.hs --- a/DDC/Core/Flow/Transform/Slurp.hs +++ b/DDC/Core/Flow/Transform/Slurp.hs @@ -1,199 +1,401 @@ module DDC.Core.Flow.Transform.Slurp - (slurpProcesses) + ( slurpProcesses + , slurpOperator + , isSeriesOperator + , isVectorOperator) where -import DDC.Core.Flow.Transform.Slurp.Alloc +import DDC.Core.Flow.Transform.Slurp.Context import DDC.Core.Flow.Transform.Slurp.Operator +import DDC.Core.Flow.Transform.Slurp.Error +import DDC.Core.Flow.Transform.Slurp.Resize 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.Flow.Transform.Deannotate import DDC.Core.Module -import Data.Maybe -import Data.List +import qualified DDC.Type.Env as Env +import DDC.Type.Env (TypeEnv) +import qualified Data.Map as Map -- | Slurp stream processes from the top level of a module. -slurpProcesses :: Module () Name -> [Process] +slurpProcesses :: Module () Name -> Either Error [Either Process (Bind Name, Exp () Name)] slurpProcesses mm = slurpProcessesX (deannotate (const Nothing) $ moduleBody mm) -- | Slurp stream processes from a module body. -slurpProcessesX :: Exp () Name -> [Process] +-- A module consists of some let-bindings wrapping a unit data constructor. +slurpProcessesX :: Exp () Name -> Either Error [Either Process (Bind Name, Exp () Name)] slurpProcessesX xx = case xx of + -- Slurp processes definitions from the let-bindings. XLet lts x' - -> slurpProcessesLts lts ++ slurpProcessesX x' + -> do ps1 <- slurpProcessesLts lts + ps2 <- slurpProcessesX x' + return $ ps1 ++ ps2 - _ -> [] + -- Ignore the unit data constructor at the end of the module. + _ + | xx == xUnit -> Right [] + | otherwise -> Left $ ErrorBadProcess xx -- | Slurp stream processes from the top-level let expressions. -slurpProcessesLts :: Lets () Name -> [Process] +slurpProcessesLts :: Lets () Name -> Either Error [Either Process (Bind Name, Exp () Name)] slurpProcessesLts (LRec binds) - = catMaybes [slurpProcessLet b x | (b, x) <- binds] + = sequence [slurpProcessLet b x | (b, x) <- binds] slurpProcessesLts (LLet b x) - = catMaybes [slurpProcessLet b x] + = sequence [slurpProcessLet b x] slurpProcessesLts _ - = [] + = return [] ------------------------------------------------------------------------------- -- | Slurp stream operators from a top-level binding. -slurpProcessLet :: Bind Name -> Exp () Name -> Maybe Process -slurpProcessLet (BName n tProcess) xx +slurpProcessLet + :: Bind Name -- ^ Binder for the whole process. + -> Exp () Name -- ^ Expression of body. + -> Either Error (Either Process (Bind Name, Exp () Name)) +slurpProcessLet (BName n t) xx + -- We assume that all type params come before the value params. - | Just (fbs, xBody) <- takeXLamFlags xx + | Just (NameTyConFlow TyConFlowProcess, [tProc, tLoopRate]) + <- takePrimTyConApps $ snd $ takeTFunAllArgResult t + , 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 + bvs = map snd + $ filter (not.fst) + $ fbs -- Slurp the body of the process. - (ctxLocal, ops, ltss, xResult) - = slurpProcessX xBody + in do + let series = slurpSeriesArguments bvs Map.empty + ctx <- slurpProcessX Env.empty series Map.empty xBody - -- Decide what rates to use when allocating vectors. - ops_alloc = patchAllocRates ops + return $ Left + $ Process + { processName = n + , processProcType = tProc + , processLoopRate = tLoopRate + , processParamFlags = fbs - -- Determine the type of the result of the process. - tResult = snd $ takeTFunAllArgResult tProcess + , processContext = ctx } - in Just $ Process - { processName = n - , processParamTypes = bts - , processParamValues = bvs +slurpProcessLet b xx + = return $ Right (b, xx) - -- 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 } +slurpSeriesArguments :: [BindF] -> Map.Map Name Context -> Map.Map Name Context +slurpSeriesArguments [] e + = e +slurpSeriesArguments (b:bs) e + | BName n t <- b + , Just (NameTyConFlow TyConFlowSeries + , [_P, tK, tA] ) + <- takePrimTyConApps t + = let op = OpSeriesOfArgument + { opResultSeries = b + , opInputRate = tK + , opElemType = tA } -slurpProcessLet _ _ - = Nothing + context = ContextRate + { contextRate = tK + , contextOps = [op] + , contextInner = [] } + in slurpSeriesArguments bs (Map.insert n context e) + | otherwise + = slurpSeriesArguments bs e ------------------------------------------------------------------------------- -- | Slurp stream operators from the body of a function and add them to --- the provided loop nest. +-- the provided loop nest. +-- +-- The process type environment records what process bindings are in scope, +-- so that we can check that the overall process is well formed. +-- This environment only needs to contain locally defined process variables, +-- not the global environment for the whole module. +-- slurpProcessX - :: ExpF -- A sequence of non-recursive let-bindings. - -> ( [Context] -- Nested contexts created by this process. - , [Operator] -- Series operators in this binding. - , [LetsF] -- Baseband statements that don't process series. - , ExpF) -- Final value of process. + :: TypeEnv Name -- ^ Process type environment. + -> Map.Map Name Context -- ^ Contexts of in-scope + -> Map.Map Name Resize -- ^ Resizes of in-scope + -> ExpF -- ^ A sequence of non-recursive let-bindings. + -> Either Error Context -slurpProcessX xx - | XLet (LLet b x) xMore <- xx - , (ctxHere, opsHere, ltsHere) <- slurpBindingX b x - , (ctxMore, opsMore, ltsMore, xResult) <- slurpProcessX xMore - = ( ctxHere ++ ctxMore - , opsHere ++ opsMore - , ltsHere ++ ltsMore - , xResult) +slurpProcessX tenv ctxs rs xx + | XLet (LLet b x) xMore <- xx + = do + -- Slurp operators from the binding. + (ctxs', rs') <- slurpBindingX tenv ctxs rs b x - -- Only handle very simple cases with one alt for now. - -- 'Invert' the case and create a let binding for each binder. - -- We can safely duplicate xScrut since it's in ANF. - | XCase xScrut [AAlt (PData dc bs) x] <- xx - , bs' <- takeSubstBoundsOfBinds bs - , length bs == length bs' - , lets <- zipWith - (\b b' -> LLet b - (XCase xScrut - [AAlt (PData dc bs) - (XVar b')])) bs bs' - = slurpProcessX (xLets lets x) + -- If this binding defined a process then add it do the environment. + let tenv' + | isProcessType $ typeOfBind b = Env.extend b tenv + | otherwise = tenv + -- Slurp the rest of the process using the new environment. + slurpProcessX tenv' ctxs' rs' xMore + +-- Slurp a process ending. +slurpProcessX tenv ctxs _rs xx + -- The process ends with a variable that has Process# type. + | XVar u <- xx + , Just t <- Env.lookup u tenv + , isProcessType t + , UName u' <- u + , Just c <- Map.lookup u' ctxs + = return c + + -- Process finishes with some expression that doesn't look like it + -- actually defines a value of type Process#. | otherwise - = ([], [], [], xx) + = Left (ErrorBadProcess xx) ------------------------------------------------------------------------------- -- | Slurp stream operators from a let-binding. slurpBindingX - :: BindF -- Binder to assign result to. - -> ExpF -- Right of the binding. - -> ( [Context] -- Nested contexts created by this binding. - , [Operator] -- Series operators in this binding. - , [LetsF]) -- Baseband statements that don't process series. + :: TypeEnv Name -- ^ Process type environment. + -> Map.Map Name Context -- ^ Contexts of in-scope + -> Map.Map Name Resize -- ^ Resizes of in-scope + -> BindF -- ^ Binder to assign result to. + -> ExpF -- ^ Right of the binding. + -> Either + Error + ( Map.Map Name Context + , Map.Map Name Resize ) + -- Decend into more let bindings. -- We get these when entering into a nested context. -slurpBindingX b1 xx +slurpBindingX tenv ctxs rs b1 xx | XLet (LLet b2 x2) xMore <- xx - , (ctxHere, opsHere, ltsHere) <- slurpBindingX b2 x2 - , (ctxMore, opsMore, ltsMore) <- slurpBindingX b1 xMore - = ( ctxHere ++ ctxMore - , opsHere ++ opsMore - , ltsHere ++ ltsMore) + = do + -- Slurp operators from the binding. + (ctxs', rs') <- slurpBindingX tenv ctxs rs b2 x2 + -- If this binding defined a process then add it to the environement. + let tenv' + | isProcessType $ typeOfBind b2 = Env.extend b2 tenv + | otherwise = tenv + + -- Slurp the rest of the process using the new environment. + slurpBindingX tenv' ctxs' rs' b1 xMore + + +-- Slurp a series# +-- This creates a new context +slurpBindingX _tenv ctxs rs b@(BName n _) + ( takeXPrimApps + -> Just ( NameOpSeries OpSeriesSeriesOfRateVec + , [ XType _tProc + , XType tK + , XType tA + , XVar vec])) + = do + let op = OpSeriesOfRateVec + { opResultSeries = b + , opInputRate = tK + , opInputRateVec = vec + , opElemType = tA } + + let context = ContextRate + { contextRate = tK + , contextOps = [op] + , contextInner = [] } + + let ctxs' = Map.insert n context ctxs + + return (ctxs', rs) + + -- Slurp a mkSel1# -- This creates a nested selector context. -slurpBindingX b +slurpBindingX tenv ctxs rs (BName n _) ( takeXPrimApps - -> Just ( NameOpFlow (OpFlowMkSel 1) - , [ XType tK1, XType _tA - , XVar uFlags - , XLAM (BName nR kR) (XLam bSel xBody)])) + -> Just ( NameOpSeries (OpSeriesMkSel 1) + , [ XType tProc + , XType tK1 + , XType _ + , XVar uFlags@(UName nFlags) + + , XLAM (BName nR kR) + (XLam bSel@(BName nSel _) + xBody)])) | kR == kRate - = let - (ctxInner, osInner, ltsInner) - = slurpBindingX b xBody + = do + flagsContext <- lookupOrDie nFlags ctxs - -- Add an intermediate edge from the flags variable to its use. - -- This is needed for the case when the flags series is one of the - -- parameters to the process, because the intermediate OpId forces - -- the scheduler to add the flags_elem = next [k] flags_series - -- statement. - UName nFlags = uFlags - nFlagsUse = NameVarMod nFlags "use" - uFlagsUse = UName nFlagsUse - bFlagsUse = BName nFlagsUse (tSeries tK1 tBool) + let nFlagsUse = NameVarMod nFlags "use" + let bFlagsUse = BName nFlagsUse (tSeries tProc tK1 tBool) - opId = OpId - { opResultSeries = bFlagsUse - , opInputRate = tK1 - , opInputSeries = uFlags - , opElemType = tBool } + let opId = OpId + { opResultSeries = bFlagsUse + , opInputRate = tK1 + , opInputSeries = uFlags + , opElemType = tBool } - context = ContextSelect - { contextOuterRate = tK1 - , contextInnerRate = TVar (UName nR) - , contextFlags = uFlagsUse - , contextSelector = bSel } + let context = ContextSelect + { contextOuterRate = tK1 + , contextInnerRate = TVar (UName nR) + , contextFlags = uFlags + , contextSelector = bSel + , contextOps = [opId] + , contextInner = [] } - in (context : ctxInner, opId : osInner, ltsInner) + context' <- insertContext context flagsContext + let ctxsInner = Map.insert nSel context' ctxs + selProc <- slurpProcessX tenv ctxsInner rs xBody --- | Slurp an operator that doesn't introduce a new context. -slurpBindingX b x - = case slurpOperator b x of + let ctxsOuter = Map.insert n selProc ctxs + return (ctxsOuter, rs) - -- 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]) +-- Slurp a mkSel1# +-- This creates a nested selector context. +slurpBindingX tenv ctxs rs (BName n _) + ( takeXPrimApps + -> Just ( NameOpSeries OpSeriesMkSegd + , [ XType tProc + , XType tK1 + , XVar uLens@(UName nLens) + + , XLAM (BName nR kR) + (XLam bSegd@(BName nSegd _) + xBody)])) + | kR == kRate + = do + lensContext <- lookupOrDie nLens ctxs + + -- Introduce new series with name of segd, + -- as copy of lens series + let nLensUse = NameVarMod nLens "use" + let bLensUse = BName nLensUse (tSeries tProc tK1 tNat) + + let opId = OpId + { opResultSeries = bLensUse + , opInputRate = tK1 + , opInputSeries = uLens + , opElemType = tNat } + + let context = ContextSegment + { contextOuterRate = tK1 + , contextInnerRate = TVar (UName nR) + , contextLens = uLens + , contextSegd = bSegd + , contextOps = [opId] + , contextInner = [] } + + context' <- insertContext context lensContext + let ctxsInner = Map.insert nSegd context' ctxs + segProc <- slurpProcessX tenv ctxsInner rs xBody + + let ctxsOuter = Map.insert n segProc ctxs + return (ctxsOuter, rs) + + +-- Slurp a series operator that doesn't introduce a new context. +slurpBindingX _ ctxs rs b@(BName n _) xx + | Just (ins, k,op) <- slurpOperator b xx + = do ins' <- mapM (flip lookupOrDie ctxs) ins + + let ctx = ContextRate + { contextRate = k + , contextOps = [op] + , contextInner = [] } + + let go [] c = insertContext ctx c + go (i:is) c = insertContext c i >>= go is + + context' <- case reverse ins' of + (i:is) -> go is i + [] -> return ctx + + let ctxs' = Map.insert n context' ctxs + return (ctxs', rs) + +-- Slurp an append operator +slurpBindingX _ ctxs rs b@(BName n _) xx + | Just (NameOpSeries OpSeriesAppend + , [ XType _P, XType tK1, XType tK2, XType tA + , XVar (UName nIn1), XVar (UName nIn2) ] ) + <- takeXPrimApps xx + = do in1 <- lookupOrDie nIn1 ctxs + in2 <- lookupOrDie nIn2 ctxs + + let opId iN iK = OpId + { opResultSeries = b + , opInputRate = iK + , opInputSeries = UName iN + , opElemType = tA } + let idCtx iN iK = ContextRate + { contextRate = iK + , contextOps = [opId iN iK] + , contextInner = [] } + + in1' <- insertContext (idCtx nIn1 tK1) in1 + in2' <- insertContext (idCtx nIn2 tK2) in2 + + let ctx = ContextAppend + { contextRate1 = tK1 + , contextInner1 = in1' + , contextRate2 = tK2 + , contextInner2 = in2' } + + + let ctxs' = Map.insert n ctx ctxs + return (ctxs', rs) + + +-- Slurp a Resize +slurpBindingX _ ctxs rs (BName n _) xx + | Just rr <- seqEitherMaybe $ slurpResize rs xx + = do r <- rr + return (ctxs, Map.insert n r rs) + + +-- Slurp a process join or resize +slurpBindingX _tenv ctxs rs (BName n _) xx + -- Just a plain variable, try to look it up in the environments + | XVar u <- xx + , UName var <- u + = case (Map.lookup var ctxs, Map.lookup var rs) of + (Just c', _) -> return (Map.insert n c' ctxs, rs) + (_, Just r') -> return (ctxs, Map.insert n r' rs) + (Nothing, Nothing) + -> Left (ErrorNotInContext var) + + -- The process ends by joining two existing processes. + -- We assume that the overall expression is well typed. + | Just (NameOpSeries OpSeriesJoin, [_, _, XVar (UName a), XVar (UName b)]) + <- takeXPrimApps xx + = do a' <- lookupOrDie a ctxs + b' <- lookupOrDie b ctxs + m' <- mergeContexts a' b' + let ctxs' = Map.insert n m' ctxs + return (ctxs', rs) + + -- The process ends by joining two existing processes. + -- We assume that the overall expression is well typed. + | Just (NameOpSeries OpSeriesResizeProc, [_, _, _, XVar (UName r), XVar (UName c)]) + <- takeXPrimApps xx + = do r' <- lookupOrDie r rs + c' <- lookupOrDie c ctxs + m' <- resizeContext r' c' + let ctxs' = Map.insert n m' ctxs + return (ctxs', rs) + + + -- Process finishes with some expression that doesn't look like it + -- actually defines a value of type Process#. +slurpBindingX _ _ _ _ xx + = Left (ErrorBadOperator xx) diff --git a/DDC/Core/Flow/Transform/Slurp/Alloc.hs b/DDC/Core/Flow/Transform/Slurp/Alloc.hs deleted file mode 100644 --- a/DDC/Core/Flow/Transform/Slurp/Alloc.hs +++ /dev/null @@ -1,41 +0,0 @@ - -module DDC.Core.Flow.Transform.Slurp.Alloc - (patchAllocRates) -where -import DDC.Core.Flow.Process.Operator - - --- | Decide what rates should be used to allocate created vectors. --- When a vector is being created in a selector context then we need to --- use the maximum possible length, which is the outer context instead --- of the inner one created by the selector. -patchAllocRates :: [Operator] -> [Operator] -patchAllocRates ops - = let - -- Build a table of output to input rates for all pack operations. - packRates - = [ (opOutputRate op, opInputRate op) - | op@OpPack{} <- ops ] - - -- Fix the number of nested contexts to some finite number so we - -- don't end up diverging if there is a loop in the list of - -- operator descriptions. - maxNestedContexts = 1000 :: Int - - getAllocRate 0 _rate - = error $ unlines - [ "ddc-core-flow.patchAllocRates" - , " Too many nested contexts." ] - - getAllocRate n rate - = case lookup rate packRates of - Just inRate -> getAllocRate (n - 1) inRate - _ -> rate - - patchOperator op@OpCreate{} - = op { opAllocRate = Just $ getAllocRate maxNestedContexts (opInputRate op) } - - patchOperator op - = op - - in map patchOperator ops diff --git a/DDC/Core/Flow/Transform/Slurp/Context.hs b/DDC/Core/Flow/Transform/Slurp/Context.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Slurp/Context.hs @@ -0,0 +1,287 @@ + +module DDC.Core.Flow.Transform.Slurp.Context + ( insertContext + , mergeContexts + , resizeContext ) +where +import DDC.Core.Flow.Context +import DDC.Core.Flow.Transform.Slurp.Error +import DDC.Core.Flow.Transform.Slurp.Resize +import DDC.Core.Flow.Prim +import DDC.Core.Flow.Exp.Simple.Compounds +import DDC.Core.Flow.Exp.Simple.Exp +import Data.List (nub) + + +-- "embed" is to be pushed inside "into" +-- only one of "embed" or "into" can contain inner contexts; +-- otherwise, no promises are made about merging these +insertContext + :: Context + -> Context + -> Either Error Context +insertContext embed into + = case into of + ContextRate{} + -> case embed of + ContextRate{} + | contextRate into == contextRate embed + -> dropops + | otherwise + -> descend + + ContextSelect{} + -> descendorpush (contextRate into == contextOuterRate embed) + + ContextSegment{} + -> descendorpush (contextRate into == contextOuterRate embed) + + ContextAppend{} + -> app into embed + + + ContextSelect{} + -> case embed of + ContextRate{} + | contextInnerRate into == contextRate embed + -> dropops + | otherwise + -> descend + + ContextSelect{} + | contextOuterRate into == contextOuterRate embed + , contextInnerRate into == contextInnerRate embed + , contextFlags into == contextFlags embed + , contextSelector into == contextSelector embed + -> dropops + | otherwise + -> descendorpush (contextInnerRate into == contextOuterRate embed) + + ContextSegment{} + -> descendorpush (contextInnerRate into == contextOuterRate embed) + + ContextAppend{} + -> app into embed + + + ContextSegment{} + -> case embed of + ContextRate{} + | contextInnerRate into == contextRate embed + -> dropops + | otherwise + -> descend + + ContextSelect{} + -> descendorpush (contextInnerRate into == contextOuterRate embed) + + ContextSegment{} + | contextOuterRate into == contextOuterRate embed + , contextInnerRate into == contextInnerRate embed + , contextLens into == contextLens embed + , contextSegd into == contextSegd embed + -> dropops + | otherwise + -> descendorpush (contextInnerRate into == contextOuterRate embed) + + ContextAppend{} + -> app into embed + + + ContextAppend{} + -> app embed into + + where + descend = + case tryInserts embed (contextInner into) of + Nothing -> Left (ErrorCannotMergeContext embed into) + Just cs -> return into { contextInner = cs } + + dropops = + let ops' = contextOps into ++ contextOps embed + in return + into { contextOps = nub ops' + , contextInner = mergeLists (contextInner into) (contextInner embed) } + + pushinner = + return + into { contextInner = mergeLists (contextInner into) [embed] } + + descendorpush p = + case descend of + Right v + -> return v + Left e + | p + -> pushinner + | otherwise + -> Left e + + app splittee injectee + = do (ls, rs) <- splitContextIntoApps splittee + ls' <- insertContext ls (contextInner1 injectee) + rs' <- insertContext rs (contextInner2 injectee) + return $ injectee + { contextInner1 = ls' + , contextInner2 = rs' } + +mergeLists :: [Context] -> [Context] -> [Context] +mergeLists lefts [] + = lefts +mergeLists lefts (right:rest) + = case mergeAny [] lefts right of + Nothing -> mergeLists (lefts ++ [right]) rest + Just ls' -> mergeLists ls' rest + where + mergeAny _ [] _ + = Nothing + mergeAny pres (l:ls) r + = case insertContext l r of + Right l' -> Just (pres ++ [l'] ++ ls) + Left _ -> mergeAny (pres ++ [l]) ls r + + + +tryInserts :: Context -> [Context] -> Maybe [Context] +tryInserts embed intos + = go intos [] + where + go [] _ + = Nothing + go (i:is) rs + = case insertContext embed i of + Right c' -> Just (rs ++ [c'] ++ is) + Left _ -> go is (rs ++ [i]) + + +-- cannot split appends. +-- but only called by insertContext, which does not take appends anyway. +splitContextIntoApps :: Context -> Either Error (Context,Context) +splitContextIntoApps ctx + = case ctx of + ContextRate{} + | Just (tl, tr) <- takeAppend $ contextRate ctx + -> do (lis, ris) <- unzip <$> mapM splitContextIntoApps (contextInner ctx) + return ( ctx { contextRate = tl + , contextInner = lis } + , ctx { contextRate = tr + , contextInner = ris } ) + + ContextSelect{} + | Just (tl, tr) <- takeAppend $ contextOuterRate ctx + -> do (lis, ris) <- unzip <$> mapM splitContextIntoApps (contextInner ctx) + return ( ctx { contextOuterRate = tl + , contextInner = lis } + , ctx { contextOuterRate = tr + , contextInner = ris } ) + + ContextSegment{} + | Just (tl, tr) <- takeAppend $ contextOuterRate ctx + -> do (lis, ris) <- unzip <$> mapM splitContextIntoApps (contextInner ctx) + return ( ctx { contextOuterRate = tl + , contextInner = lis } + , ctx { contextOuterRate = tr + , contextInner = ris } ) + + ContextAppend{} + -> return ( contextInner1 ctx + , contextInner2 ctx ) + + _ + -> -- Left (ErrorCannotSplitContext ctx) + return (ctx, ctx) + + + where + + +mergeContexts :: Context -> Context -> Either Error Context +mergeContexts a b + = insertContext b a + +resizeContext :: Resize -> Context -> Either Error Context +resizeContext resize ctx + = case resize of + Id _ + -> return ctx + AppL a b + -> return + ContextAppend + { contextRate1 = a + , contextInner1 = wrapCtx b ctx + , contextRate2 = b + , contextInner2 = emptyCtx a + } + + AppR a b + -> return + ContextAppend + { contextRate1 = a + , contextInner1 = emptyCtx a + , contextRate2 = b + , contextInner2 = wrapCtx b ctx + } + + App _ k' _ l' ls rs + | ContextAppend{} <- ctx + -> do in1 <- resizeContext ls (contextInner1 ctx) + in2 <- resizeContext rs (contextInner2 ctx) + return + ContextAppend + { contextRate1 = k' + , contextInner1 = in1 + , contextRate2 = l' + , contextInner2 = in2 } + | otherwise + -> Left (ErrorCannotResizeContext ctx) + + Sel1 _ _k _ r + -> do ctx' <- resizeContext r ctx + return $ ctx' + + Segd _ _k _ r + -> do ctx' <- resizeContext r ctx + return $ ctx' + + Cross _ k _ r + -> do ctx' <- resizeContext r ctx + return $ wrapCtx k ctx' + + + + +emptyCtx :: Type Name -> Context +emptyCtx k + = ContextRate + { contextRate = k + , contextInner = [] + , contextOps = [] } + +wrapCtx :: Type Name -> Context -> Context +wrapCtx k ctx + = case ctx of + ContextRate{} + | contextRate ctx == k + -> ctx + + ContextAppend{} + | Just (l,r) <- takeAppend k + , contextRate1 ctx == l + , contextRate2 ctx == r + -> ctx + + _ + | otherwise + -> ContextRate + { contextRate = k + , contextInner = [ctx] + , contextOps = [] } + +takeAppend ty + | Just (NameTyConFlow TyConFlowRateAppend, [tK, tL]) + <- takePrimTyConApps ty + = Just (tK, tL) + | otherwise + = Nothing + + diff --git a/DDC/Core/Flow/Transform/Slurp/Error.hs b/DDC/Core/Flow/Transform/Slurp/Error.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Slurp/Error.hs @@ -0,0 +1,74 @@ + +module DDC.Core.Flow.Transform.Slurp.Error + ( Error (..) ) +where +import DDC.Core.Flow.Exp +import DDC.Core.Flow.Prim +import DDC.Core.Flow.Transform.Annotate +import DDC.Core.Flow.Context +import DDC.Core.Flow.Process.Pretty () +import DDC.Core.Pretty + + +-- | Things that can go wrong when slurping a process spec from +-- Disciple Core Flow code. +data Error + -- | Invalid series process definition. + = ErrorBadProcess (Exp () Name) + + -- | Invalid operator definition in process. + | ErrorBadOperator (Exp () Name) + + -- | A series, process or resize is not bound locally, + -- so is not in context + | ErrorNotInContext Name + + -- | Cannot merge contexts + | ErrorCannotMergeContext Context Context + + -- | Cannot split contexts + | ErrorCannotSplitContext Context + + -- | Cannot resize a non-append + | ErrorCannotResizeContext Context + deriving Show + + +instance Pretty Error where + ppr err + = case err of + ErrorBadProcess x + -> vcat [ text "Bad series process definition." + , empty + , ppr (annotate () x) ] + + ErrorBadOperator x + -> vcat [ text "Bad series operator." + , empty + , ppr (annotate () x) ] + + ErrorNotInContext n + -> vcat [ text "Referenced name not in context." + , text "All Series, Processes and Resizes must be locally bound" + , empty + , ppr n ] + + ErrorCannotMergeContext c1 c2 + -> vcat [ text "Cannot merge contexts" + , empty + , text "Embed:" + , ppr c1 + , empty + , text "Into:" + , ppr c2 ] + + ErrorCannotSplitContext c + -> vcat [ text "Cannot split context into its append parts" + , empty + , ppr c] + + ErrorCannotResizeContext c + -> vcat [ text "Cannot resize append context, because it's not an append" + , empty + , ppr c] + diff --git a/DDC/Core/Flow/Transform/Slurp/Operator.hs b/DDC/Core/Flow/Transform/Slurp/Operator.hs --- a/DDC/Core/Flow/Transform/Slurp/Operator.hs +++ b/DDC/Core/Flow/Transform/Slurp/Operator.hs @@ -1,13 +1,15 @@ module DDC.Core.Flow.Transform.Slurp.Operator - (slurpOperator) + ( slurpOperator + , isSeriesOperator + , isVectorOperator) where import DDC.Core.Flow.Process.Operator import DDC.Core.Flow.Exp import DDC.Core.Flow.Prim -import DDC.Core.Flow.Prim.TyConPrim -import DDC.Core.Compounds.Simple -import DDC.Type.Pretty () +import DDC.Core.Flow.Exp.Simple.Compounds +import DDC.Core.Pretty () +import Control.Monad -- | Slurp a stream operator from a let-binding binding. @@ -15,88 +17,181 @@ slurpOperator :: Bind Name -> Exp () Name - -> Maybe Operator + -> Maybe ([Name], Type Name, Operator) + -- name of contexts to insert into, rate, operator slurpOperator bResult xx + + -- Rep ----------------------------------------- + | Just ( NameOpSeries OpSeriesRep + , [ XType _P, XType tK1, XType tA, xVal]) + <- takeXPrimApps xx + = Just ( [] + , tK1 + , OpRep + { opResultSeries = bResult + , opOutputRate = tK1 + , opElemType = tA + , opInputExp = xVal } ) - -- Create -------------------------------------- - | Just ( NameOpFlow OpFlowVectorOfSeries - , [ XType tRate, XType tA, (XVar uSeries) ]) + -- Reps ---------------------------------------- + | Just ( NameOpSeries OpSeriesReps + , [ XType _P, XType tK1, XType tK2, XType tA, XVar uSegd@(UName nSegd), XVar uS@(UName nS) ]) <- takeXPrimApps xx - = Just $ OpCreate - { opResultVector = bResult - , opInputRate = tRate - , opInputSeries = uSeries - , opAllocRate = Nothing - , opElemType = tA } + = Just ( [nSegd, nS] + , tK2 + , OpReps + { opResultSeries = bResult + , opInputRate = tK1 + , opOutputRate = tK2 + , opElemType = tA + , opSegdBound = uSegd + , opInputSeries = uS } ) + -- Indices ------------------------------------- + | Just ( NameOpSeries OpSeriesIndices + , [ XType _P, XType tK1, XType tK2, XVar uSegd@(UName nSegd)]) + <- takeXPrimApps xx + = Just ( [nSegd] + , tK2 + , OpIndices + { opResultSeries = bResult + , opInputRate = tK1 + , opOutputRate = tK2 + , opSegdBound = uSegd } ) + + -- Fill ---------------------------------------- + | Just ( NameOpSeries OpSeriesFill + , [ XType _P, XType tK, XType tA, XVar uV, XVar uS@(UName nS) ]) + <- takeXPrimApps xx + = Just ( [nS] + , tK + , OpFill + { opResultBind = bResult + , opTargetVector = uV + , opInputRate = tK + , opInputSeries = uS + , opElemType = tA } ) + + + -- Gather -------------------------------------- + | Just ( NameOpSeries OpSeriesGather + , [ XType _P, XType tK1, XType tK2, XType tA, XVar uV, XVar uS@(UName nS) ]) + <- takeXPrimApps xx + = Just ( [nS] + , tK2 + , OpGather + { opResultBind = bResult + , opSourceVector = uV + , opVectorRate = tK1 + , opSourceIndices = uS + , opInputRate = tK2 + , opElemType = tA } ) + + + -- Scatter ------------------------------------- + | Just ( NameOpSeries OpSeriesScatter + , [ XType _P, XType tK, XType tA, XVar uV, XVar uIndices@(UName nIndices), XVar uElems@(UName nElems) ]) + <- takeXPrimApps xx + = Just ( [nIndices, nElems] + , tK + , OpScatter + { opResultBind = bResult + , opTargetVector = uV + , opSourceIndices = uIndices + , opSourceElems = uElems + , opInputRate = tK + , opElemType = tA } ) + + -- Map ----------------------------------------- - | Just (NameOpFlow (OpFlowMap n), xs) + | Just (NameOpSeries (OpSeriesMap n), xs) <- takeXPrimApps xx , n >= 1 - , XType tR : xsArgs2 <- xs + , XType _P : 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 ] + , usSeries <- [ u | XVar u <- xsSeries ] + , nsSeries <- [ un | UName un <- usSeries ] , length usSeries == n , Just (psIn, xBody) <- takeXLams xWorker , length psIn == n - = Just $ OpMap + = Just ( nsSeries + , tR + , 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 } + , opWorkerBody = xBody } ) -- Pack ---------------------------------------- - | Just ( NameOpFlow OpFlowPack - , [ XType tRateInput, XType tRateOutput, XType tElem - , _xSel, (XVar uSeries) ]) <- takeXPrimApps xx - = Just $ OpPack + | Just ( NameOpSeries OpSeriesPack + , [ XType _P + , XType tRateInput, XType tRateOutput + , XType tElem + , XVar (UName nSel), XVar uSeries@(UName nSeries) ]) <- takeXPrimApps xx + = Just ( [nSel, nSeries] + , tRateOutput + , OpPack { opResultSeries = bResult , opInputRate = tRateInput , opInputSeries = uSeries , opOutputRate = tRateOutput - , opElemType = tElem } + , opElemType = tElem } ) + + -- Generate ------------------------------------ + | Just ( NameOpSeries OpSeriesGenerate + , [ XType _P, XType tK, XType _, xWorker ]) + <- takeXPrimApps xx + , Just ([bIx], xBody) <- takeXLams xWorker + = Just ( [] + , tK + , OpGenerate + { opResultSeries = bResult + , opOutputRate = tK + , opWorkerParamIndex = bIx + , opWorkerBody = xBody } ) + + -- Reduce -------------------------------------- + | Just ( NameOpSeries OpSeriesReduce + , [ XType _P, XType tK, XType _ + , XVar uRef, xWorker, xZ, XVar uS@(UName nS) ]) + <- takeXPrimApps xx + , Just ([bAcc, bElem], xBody) <- takeXLams xWorker + = Just ( [nS] + , tK + , OpReduce + { opResultBind = bResult + , opTargetRef = uRef + , opInputRate = tK + , opInputSeries = uS + , opZero = xZ + , opWorkerParamAcc = bAcc + , opWorkerParamElem = bElem + , opWorkerBody = xBody } ) + | otherwise = Nothing + + +-- | Check if some binding is a series operator. +isSeriesOperator :: Exp () Name -> Bool +isSeriesOperator xx + = case liftM fst $ takeXPrimApps xx of + Just (NameOpSeries _) -> True + _ -> False + + +-- | Check if some binding is a vector operator. +isVectorOperator :: Exp () Name -> Bool +isVectorOperator xx + = case liftM fst $ takeXPrimApps xx of + Just (NameOpVector _) -> True + _ -> False diff --git a/DDC/Core/Flow/Transform/Slurp/Resize.hs b/DDC/Core/Flow/Transform/Slurp/Resize.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/Slurp/Resize.hs @@ -0,0 +1,120 @@ + +module DDC.Core.Flow.Transform.Slurp.Resize + ( Resize(..) + , slurpResize + , lookupOrDie + , seqEitherMaybe ) +where +import DDC.Core.Flow.Transform.Slurp.Error +import DDC.Core.Flow.Prim +import DDC.Core.Flow.Exp.Simple.Compounds +import DDC.Core.Flow.Exp.Simple.Exp +import qualified Data.Map as Map + +type Ty = Type Name + +data Resize + = Id Ty + | AppL Ty Ty + | AppR Ty Ty + | App Ty Ty Ty Ty Resize Resize + | Sel1 Ty Ty Ty Resize + | Segd Ty Ty Ty Resize + | Cross Ty Ty Ty Resize + deriving Show + +slurpResize + :: Map.Map Name Resize + -> Exp () Name + -> Either Error (Maybe Resize) + +slurpResize rs xx + + | Just ( NameOpSeries OpSeriesResizeId + , [ _, tK ] ) + <- takeXPrimApps xx + = return (Id <$> nameOfType tK) + + | Just ( NameOpSeries OpSeriesResizeAppL + , [ _, tK, tL ] ) + <- takeXPrimApps xx + = return (AppL <$> nameOfType tK <*> nameOfType tL) + + | Just ( NameOpSeries OpSeriesResizeAppR + , [ _, tK, tL ] ) + <- takeXPrimApps xx + = return (AppR <$> nameOfType tK <*> nameOfType tL) + + | Just ( NameOpSeries OpSeriesResizeApp + , [ _, tK, tK', tL, tL' + , XVar (UName rL) + , XVar (UName rR) ] ) + <- takeXPrimApps xx + = do rL' <- lookupOrDie rL rs + rR' <- lookupOrDie rR rs + return (App <$> nameOfType tK <*> nameOfType tK' + <*> nameOfType tL <*> nameOfType tL' + <*> Just rL' <*> Just rR') + + | Just ( NameOpSeries OpSeriesResizeSel1 + , [ _, tJ, tK, tL + , _ + , XVar (UName r) ] ) + <- takeXPrimApps xx + = do r' <- lookupOrDie r rs + return (Sel1 <$> nameOfType tJ <*> nameOfType tK + <*> nameOfType tL + <*> Just r') + + | Just ( NameOpSeries OpSeriesResizeSegd + , [ _, tJ, tK, tL + , _ + , XVar (UName r) ] ) + <- takeXPrimApps xx + = do r' <- lookupOrDie r rs + return (Segd <$> nameOfType tJ <*> nameOfType tK + <*> nameOfType tL + <*> Just r') + + + | Just ( NameOpSeries OpSeriesResizeCross + , [ _, tJ, tK, tL + , _ + , XVar (UName r) ] ) + <- takeXPrimApps xx + = do r' <- lookupOrDie r rs + return (Cross <$> nameOfType tJ <*> nameOfType tK + <*> nameOfType tL + <*> Just r') + + + + | otherwise + = return Nothing + + +nameOfType :: Exp () Name -> Maybe (Type Name) + +nameOfType (XType t) + = Just t + +nameOfType _ + = Nothing + + +lookupOrDie + :: Name + -> Map.Map Name v + -> Either Error v +lookupOrDie n m + = case Map.lookup n m of + Just v -> return v + Nothing -> Left $ ErrorNotInContext n + +seqEitherMaybe :: Either a (Maybe b) -> Maybe (Either a b) +seqEitherMaybe x + = case x of + Left a -> Just (Left a) + Right Nothing -> Nothing + Right (Just b) -> Just (Right b) + diff --git a/DDC/Core/Flow/Transform/Thread.hs b/DDC/Core/Flow/Transform/Thread.hs --- a/DDC/Core/Flow/Transform/Thread.hs +++ b/DDC/Core/Flow/Transform/Thread.hs @@ -10,11 +10,10 @@ 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.Exp.Annot as C import DDC.Core.Transform.Thread import DDC.Core.Transform.Reannotate -import DDC.Core.Check (AnTEC (..)) +import DDC.Core.Check (AnTEC (..)) import qualified DDC.Core.Check as Check @@ -28,7 +27,7 @@ , configVoidType = tUnit , configWrapResultType = wrapResultType , configWrapResultExp = wrapResultExp - , configThreadMe = threadType + , configThreadMe = threadType , configThreadPat = unwrapResult } @@ -45,53 +44,38 @@ -- | Wrap the result of a stateful computation with the state token. -wrapResultExp +wrapResultExp :: Exp (AnTEC () Name) Name -- ^ World expression -> Exp (AnTEC () Name) Name -- ^ Result expression -> Exp () Name wrapResultExp xWorld xResult -- Rewrite Unit => World - | Just aResult <- takeAnnotOfExp xResult - , annotType aResult == tUnit + | aResult <- annotOfExp xResult + , annotType aResult == tUnit = reannotate annotTail xWorld - -- Rewrite (TupleN a1 a2 .. x1 x2 ..) + -- Rewrite (TupleN a1 a2 .. x1 x2 ..) -- => (TupleN World# a1 a2 .. world x1 x2 ..) - | Just aWorld <- takeAnnotOfExp xWorld - , Just aResult <- takeAnnotOfExp xResult + | aWorld <- annotOfExp xWorld + , aResult <- annotOfExp xResult = let tWorld' = annotType aWorld tResult = annotType aResult xWorld' = reannotate annotTail xWorld xResult' = reannotate annotTail xResult - in - -- ISSUE #308: Handle Tuple arities generically in thread transform. - case C.takeXConApps xResult' of - Just (dc, [xT1, xT2 - , x1, x2]) - | dc == dcTupleN 2 - -> C.xApps () (XCon () (dcTupleN 3)) - [ XType tWorld', xT1, xT2 - , xWorld', x1, x2] - - Just (dc, [xT1, xT2, xT3 - , x1, x2, x3]) - | dc == dcTupleN 3 - -> C.xApps () (XCon () (dcTupleN 4)) - [ XType tWorld', xT1, xT2, xT3 - , xWorld', x1, x2, x3] - - Just (dc, [xT1, xT2, xT3, xT4 - , x1, x2, x3, x4]) - | dc == dcTupleN 4 - -> C.xApps () (XCon () (dcTupleN 5)) - [ XType tWorld', xT1, xT2, xT3, xT4 - , xWorld', x1, x2, x3, x4] - + in case C.takeXConApps xResult' of + Just (dc, xa) + | DaConPrim (NameDaConFlow (DaConFlowTuple n)) _ <- dc + , x <- length xa + , x >= 2 + -> let (b, a) = splitAt (x `quot` 2) xa + in C.xApps () (XCon () (dcTupleN $ n + 1)) + $ XType (annotTail aWorld) tWorld' : b -- World# : a1 a2 .. + ++ xWorld' : a -- world : x1 x2 .. _ -> C.xApps () (XCon () (dcTupleN 2)) - [ XType tWorld' - , XType tResult + [ XType (annotTail aWorld) tWorld' + , XType (annotTail aResult) tResult , xWorld' , xResult' ] @@ -104,10 +88,10 @@ unwrapResult _ = Just unwrap - where unwrap bWorld bsResult + where unwrap bWorld bsResult | [bResult] <- bsResult , typeOfBind bResult == tUnit - = PData dcTuple1 [bWorld] + = PData dcTuple1 [bWorld] | otherwise = PData (dcTupleN (length (bWorld : bsResult))) @@ -124,80 +108,99 @@ -- Assignables -------------------------- -- new# :: [a : Data]. a -> World# -> T2# (World#, Ref# a) NameOpStore OpStoreNew - -> Just $ tForall kData - $ \tA -> tA + -> Just $ tForall kData + $ \tA -> tA `tFun` tWorld `tFun` (tTuple2 tWorld (tRef tA)) -- read# :: [a : Data]. Ref# a -> World# -> T2# (World#, a) NameOpStore OpStoreRead -> Just $ tForall kData - $ \tA -> tRef tA + $ \tA -> tRef tA `tFun` tWorld `tFun` (tTuple2 tWorld (tRef tA)) -- write# :: [a : Data]. Ref# -> a -> World# -> World# - NameOpStore OpStoreWrite + NameOpStore OpStoreWrite -> Just $ tForall kData - $ \tA -> tRef tA `tFun` tA + $ \tA -> tRef tA `tFun` tA `tFun` tWorld `tFun` tWorld -- Vectors ------------------------------- - -- newVector# :: [a : Data]. Nat# -> World# -> T2# World# (Vector# a) + -- vnew# :: [a : Data]. Nat# -> World# -> T2# World# (Vector# a) NameOpStore OpStoreNewVector -> Just $ tForall kData - $ \tA -> tNat + $ \tA -> tNat `tFun` tWorld `tFun` (tTuple2 tWorld (tVector tA)) - -- newVectorN# :: [a : Data]. [k : Rate]. RateNat# k - -- -> World# -> T2# (World#, Vector# a) + -- vnew# :: [a : Data]. [k : Rate]. RateNat# k + -- -> World# -> T2# (World#, Vector# a) NameOpStore OpStoreNewVectorN -> Just $ tForalls [kData, kRate] - $ \[tA, tK] - -> tRateNat tK + $ \[tA, tK] + -> tRateNat tK `tFun` tWorld `tFun` (tTuple2 tWorld (tVector tA)) - -- readVector# :: [a : Data]. Vector# a -> Nat# -> World# -> T2# World# a - NameOpStore OpStoreReadVector + -- vread# :: [a : Data]. Vector# a -> Nat# -> World# -> T2# World# a + NameOpStore (OpStoreReadVector _) -> Just $ tForall kData - $ \tA -> tA `tFun` tVector tA `tFun` tNat + $ \tA -> tA `tFun` tBuffer tA `tFun` tNat `tFun` tWorld `tFun` (tTuple2 tWorld tA) - -- writeVector# :: [a : Data]. Vector# a -> Nat# -> a -> World# -> World# - NameOpStore OpStoreWriteVector + -- vwrite# :: [a : Data]. Vector# a -> Nat# -> a -> World# -> World# + NameOpStore (OpStoreWriteVector _) -> Just $ tForall kData - $ \tA -> tA `tFun` tVector tA `tFun` tNat `tFun` tA + $ \tA -> tA `tFun` tBuffer tA `tFun` tNat `tFun` tA `tFun` tWorld `tFun` tWorld - -- sliceVector# :: [a : Data]. Nat# -> Vector# a -> World# -> T2# World# (Vector# a) - NameOpStore OpStoreSliceVector + -- vtrunc# :: [a : Data]. Nat# -> Vector# a -> World# -> World# + NameOpStore OpStoreTruncVector -> Just $ tForall kData - $ \tA -> tNat `tFun` tVector tA - `tFun` tWorld `tFun` (tTuple2 tWorld (tVector tA)) - + $ \tA -> tNat `tFun` tVector tA + `tFun` tWorld `tFun` tWorld - -- Streams ------------------------------ + -- Series ------------------------------ -- next# :: [k : Rate]. [a : Data] -- . Series# k a -> Int# -> World# -> (World#, a) - NameOpStore OpStoreNext - -> Just $ tForalls [kRate, kData] - $ \[tK, tA] -> tSeries tK tA `tFun` tInt - `tFun` tWorld `tFun` (tTuple2 tWorld tA) + NameOpConcrete (OpConcreteNext 1) + -> Just $ tForalls [kProc, kRate, kData] + $ \[tP, tK, tA] + -> tSeries tP tK tA `tFun` tInt + `tFun` tWorld `tFun` (tTuple2 tWorld tA) - -- Contexts ----------------------------- - -- loopn# :: [k : Rate]. RateNat# k - -- -> (Nat# -> World# -> World#) + -- nextN# :: [k : Rate]. [a : Data] + -- . Series# k a -> Int# -> World# -> (World#, a) + NameOpConcrete (OpConcreteNext c) + | c >= 2 + -> Just $ tForalls [kProc, kRate, kData] + $ \[tP, tK, tA] + -> tSeries tP (tDown c tK) tA `tFun` tInt + `tFun` tWorld `tFun` (tTuple2 tWorld (tVec c tA)) + + -- Control ----------------------------- + -- loopn# :: [k : Rate]. RateNat# k + -- -> (Nat# -> World# -> World#) -- -> World# -> World# - NameOpLoop OpLoopLoopN + NameOpControl OpControlLoopN -> Just $ tForalls [kRate] $ \[tK] -> tRateNat tK `tFun` (tNat `tFun` tWorld `tFun` tWorld) `tFun` tWorld `tFun` tWorld - + -- guard# - NameOpLoop OpLoopGuard - -> Just $ tRef tNat - `tFun` tBool - `tFun` (tNat `tFun` tWorld `tFun` tWorld) + NameOpControl OpControlGuard + -> Just $ tBool + `tFun` (tUnit `tFun` tWorld `tFun` tWorld) `tFun` tWorld `tFun` tWorld + + -- split# :: [k : Rate]. RateNat# k + -- -> (RateNat# (Down8# k) -> World# -> World#) + -- -> (RateNat# (Tail8# k) -> World# -> World#) + -- -> World# -> World# + NameOpControl (OpControlSplit c) + -> Just $ tForall kRate + $ \tK -> tRateNat tK + `tFun` (tRateNat (tDown c tK) `tFun` tWorld `tFun` tWorld) + `tFun` (tRateNat (tTail c tK) `tFun` tWorld `tFun` tWorld) + `tFun` tWorld `tFun` tWorld _ -> Nothing diff --git a/DDC/Core/Flow/Transform/TransformUpX.hs b/DDC/Core/Flow/Transform/TransformUpX.hs new file mode 100644 --- /dev/null +++ b/DDC/Core/Flow/Transform/TransformUpX.hs @@ -0,0 +1,85 @@ + +-- | General purpose tree walking boilerplate. +module DDC.Core.Flow.Transform.TransformUpX + ( TransformUpMX(..) + , transformUpX + , transformUpX' + + -- * Via the Simple AST + , transformSimpleUpMX + , transformSimpleUpX + , transformSimpleUpX') +where +import DDC.Core.Exp.Annot +import DDC.Core.Transform.TransformUpX +import DDC.Core.Flow.Transform.Annotate +import DDC.Core.Flow.Transform.Deannotate +import Data.Functor.Identity +import DDC.Core.Env.EnvX (EnvX) +import qualified DDC.Core.Flow.Exp.Simple.Exp as S +import qualified DDC.Core.Env.EnvX as EnvX + + +-- Simple --------------------------------------------------------------------- +-- | Like `transformUpMX`, but the worker takes the Simple version of the AST. +-- +-- * To avoid repeated conversions between the different versions of the AST, +-- the worker should return `Nothing` if the provided expression is unchanged. +transformSimpleUpMX + :: (Ord n, TransformUpMX m c, Monad m) + => (EnvX n -> S.Exp a n -> m (Maybe (S.Exp a n))) + -- ^ The worker function is given the current + -- kind and type environments. + -> EnvX n -- ^ Initial type environment. + -> c a n -- ^ Transform thing thing. + -> m (c a n) + +transformSimpleUpMX f env0 xx0 + = let + f' env xx + = do let a = annotOfExp xx + let sxx = deannotate (const Nothing) xx + msxx' <- f env sxx + case msxx' of + Nothing -> return $ xx + Just sxx' -> return $ annotate a sxx' + + in transformUpMX f' env0 xx0 + + +-- | Like `transformUpX`, but the worker takes the Simple version of the AST. +-- +-- * To avoid repeated conversions between the different versions of the AST, +-- the worker should return `Nothing` if the provided expression is unchanged. +transformSimpleUpX + :: forall (c :: * -> * -> *) a n + . (Ord n, TransformUpMX Identity c) + => (EnvX n -> S.Exp a n -> Maybe (S.Exp a n)) + -- ^ The worker function is given the current + -- kind and type environments. + -> EnvX n -- ^ Initial type environment. + -> c a n -- ^ Transform this thing. + -> c a n + +transformSimpleUpX f env xx + = runIdentity + $ transformSimpleUpMX + (\env' x -> return (f env' x)) env xx + + +-- | Like `transformUpX'`, but the worker takes the Simple version of the AST. +-- +-- * To avoid repeated conversions between the different versions of the AST, +-- the worker should return `Nothing` if the provided expression is unchanged. +transformSimpleUpX' + :: forall (c :: * -> * -> *) a n + . (Ord n, TransformUpMX Identity c) + => (S.Exp a n -> Maybe (S.Exp a n)) + -- ^ The worker function is given the current + -- kind and type environments. + -> c a n -- ^ Transform this thing. + -> c a n + +transformSimpleUpX' f xx + = transformSimpleUpX (\_ -> f) EnvX.empty xx + diff --git a/DDC/Core/Flow/Transform/Wind.hs b/DDC/Core/Flow/Transform/Wind.hs --- a/DDC/Core/Flow/Transform/Wind.hs +++ b/DDC/Core/Flow/Transform/Wind.hs @@ -28,11 +28,12 @@ , 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 DDC.Core.Exp.Annot +import DDC.Core.Transform.TransformModX +import DDC.Core.Flow.Compounds + (tNat, dcNat, dcTupleN, dcBool, tTupleN, kRate) import qualified Data.Map as Map import Data.Map (Map) @@ -103,15 +104,19 @@ -- | 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 } + { -- | Whether we're in the matching or non-matching branch. + contextGuardFlag :: Bool } deriving Show +-- | Check if some `Context` is a `ContextLoop`. +isContextLoop :: Context -> Bool +isContextLoop cc + = case cc of + ContextLoop{} -> True + _ -> False + + -- | Build a tailcall from the current context. -- This tells us where to go after finishing the body of a loop. makeTailCallFromContexts :: a -> RefMap -> [Context] -> Exp a Name @@ -122,12 +127,14 @@ in xApps a xLoop xArgs -makeTailCallFromContexts _ _ _ +makeTailCallFromContexts _ _ contexts = error $ unlines [ "ddc-core-flow.makeTailCallFromContexts" - , " Can't make a tailcall for this context." ] + , " Can't make a tailcall for this context." + , " context = " ++ show contexts ] +------------------------------------------------------------------------------- -- | Slurp expressions to update each of the accumulators of the loop. -- We assume that there have been no other updates to the loop -- counter, and we generated the code ourselves. @@ -156,17 +163,7 @@ -- 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 (ContextGuard _flag : more) = slurpArgUpdates a refMap args more slurpArgUpdates _ _ _ (ContextLoop{} : _) @@ -183,42 +180,32 @@ xIncrement a xx = xApps a (XVar a (UPrim (NamePrimArith PrimArithAdd) (typePrimArith PrimArithAdd))) - [ XType tNat, xx, XCon a (dcNat 1) ] + [ XType a tNat, xx, XCon a (dcNat 1) ] -- | Build an expression that substracts two integers. xSubInt :: a -> Exp a Name -> Exp a Name -> Exp a Name xSubInt a x1 x2 = xApps a (XVar a (UPrim (NamePrimArith PrimArithSub) (typePrimArith PrimArithSub))) - [ XType tNat, x1, x2] + [ XType a tNat, x1, x2] ------------------------------------------------------------------------------- +-- | Apply the wind transform to a single module. +-- Only apply wind to top-level let binds with Forall (k : Rate)..., +-- as that seems like a good indication that something is a lowered series. 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' + = transformModLet check m + where + check b x + | t <- typeOfBind b + , Just (bs, _) <- takeTForalls t + , elem kRate $ map typeOfBind bs + = windBodyX refMapZero [] x - _ -> xx + | otherwise + = x ------------------------------------------------------------------------------- @@ -242,7 +229,7 @@ -- XLet a (LLet (BName nRef _) x) x2 | Just ( NameOpStore OpStoreNew - , [XType tElem, xVal] ) <- takeXPrimApps x + , [XType _ tElem, xVal] ) <- takeXPrimApps x -> let -- Add the new ref record to the map. info = RefInfo @@ -268,7 +255,7 @@ -- XLet a (LLet bResult x) x2 | Just ( NameOpStore OpStoreRead - , [XType _tElem, XVar _ (UName nRef)] ) + , [XType _ _tElem, XVar _ (UName nRef)] ) <- takeXPrimApps x , Just info <- lookupRefInfo refMap nRef , Just nVal <- nameOfRefInfo info @@ -281,7 +268,7 @@ -- to just bind the new value. XLet a (LLet (BNone _) x) x2 | Just ( NameOpStore OpStoreWrite - , [XType _tElem, XVar _ (UName nRef), xVal]) + , [XType _ _tElem, XVar _ (UName nRef), xVal]) <- takeXPrimApps x , refMap' <- bumpVersionInRefMap nRef refMap , Just info <- lookupRefInfo refMap' nRef @@ -294,17 +281,16 @@ ----------------------------------------- -- Detect loop combinator. XLet a (LLet (BNone _) x) x2 - | Just ( NameOpLoop OpLoopLoopN - , [ XType tK, xLength + | Just ( NameOpControl OpControlLoopN + , [ XType _ tK, xLength , XLam _ bIx@(BName nIx _) xBody]) <- takeXPrimApps x -> let -- Name of the new loop function. - TVar (UName nK) = tK - nLoop = NameVarMod nK "loop" + nLoop = NameVar "loop" bLoop = BName nLoop tLoop uLoop = UName nLoop - nLength = NameVarMod nK "length" + nLength = NameVarMod nLoop "length" bLength = BName nLength tNat uLength = UName nLength @@ -383,22 +369,16 @@ ----------------------------------------- -- Detect guard combinator. XLet a (LLet (BNone _) x) x2 - | Just ( NameOpLoop OpLoopGuard - , [ XVar _ (UName nCountRef) - , xFlag - , XLam _ bCount xBody ]) <- takeXPrimApps x + | Just ( NameOpControl OpControlGuard + , [ xFlag + , XLam _ _unit xBody ]) <- takeXPrimApps x -> let - Just infoCount = lookupRefInfo refMap nCountRef - - Just nCount = nameOfRefInfo infoCount - context' = context ++ [ ContextGuard - { contextGuardCounter = nCountRef - , contextGuardFlag = True } ] + { contextGuardFlag = True } ] - xBody' = XLet a (LLet bCount (XVar a (UName nCount))) - $ windBodyX refMap context' xBody + xBody' = -- XLet a (LLet bCount (XVar a (UName nCount))) + windBodyX refMap context' xBody in XCase a xFlag [ AAlt (PData (dcBool True) []) xBody' @@ -407,13 +387,24 @@ ----------------------------------------- -- Detect end value. - -- When we hit a Unit at the top level of the body of a loop then - -- we know it's time to do the recursive call. + -- If we're inside a loop and hit a Unit at the top-level of the body + -- then we know it's time to do the recursive call. XCon a dc - | dc == dcUnit + | any isContextLoop context + , dc == dcUnit -> makeTailCallFromContexts a refMap context + ----------------------------------------- + -- Enter into both branches of a split. + XApp{} + | Just ( NameOpControl (OpControlSplit n) + , [ XType _ tK, xN, xBranch1, xBranch2 ]) <- takeXPrimApps xx + -> let xBranch1' = down xBranch1 + xBranch2' = down xBranch2 + in xSplit n tK xN xBranch1' xBranch2' + + -- Boilerplate -------------------------- XVar{} -> xx XCon{} -> xx @@ -449,17 +440,38 @@ XWitness{} -> xx + +------------------------------------------------------------------------------- +type TypeF = Type Name +type ExpF = Exp () Name + xNatOfRateNat :: Type Name -> Exp () Name -> Exp () Name xNatOfRateNat tK xR = xApps () - (xVarOpFlow OpFlowNatOfRateNat) - [XType tK, xR] + (xVarOpConcrete OpConcreteNatOfRateNat) + [XType () tK, xR] -xVarOpFlow :: OpFlow -> Exp () Name -xVarOpFlow op - = XVar () (UPrim (NameOpFlow op) (typeOpFlow op)) +xVarOpConcrete :: OpConcrete -> Exp () Name +xVarOpConcrete op + = XVar () (UPrim (NameOpConcrete op) (typeOpConcrete op)) + +xSplit :: Int + -> TypeF + -> ExpF + -> ExpF -> ExpF -> ExpF +xSplit n tK xRN xDownFn xTailFn + = xApps () + (xVarOpControl $ OpControlSplit n) + [ XType () tK, xRN, xDownFn, xTailFn ] + + +xVarOpControl :: OpControl -> Exp () Name +xVarOpControl op + = XVar () (UPrim (NameOpControl op) (typeOpControl op)) + + ------------------------------------------------------------------------------- -- | Make the type of a loop result, -- given the types of the accumulators for that loop. @@ -484,7 +496,7 @@ [] -> xUnit a [x] -> x _ -> xApps a (XCon a (dcTupleN $ length tsAccs)) - ([XType t | t <- tsAccs] ++ xsAccs) + ([XType a t | t <- tsAccs] ++ xsAccs) -- | Call a loop, and unpack its result. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyrite (K) 2007-2013 The Disciplined Disciple Compiler Strike Force +Copyrite (K) 2007-2016 The Disciplined Disciple Compiler Strike Force All rights reversed. Permission is hereby granted, free of charge, to any person obtaining a copy @@ -13,18 +13,4 @@ The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - -------------------------------------------------------------------------------- -Under Australian law copyright is free and automatic. -By contributing to DDC authors grant all rights they have regarding their -contributions to the other members of the Disciplined Disciple Compiler Strike -Force, past, present and future, as well as placing their contributions under -the above license. - -Use "darcs show authors" to get a list of Strike Force members. - -------------------------------------------------------------------------------- -Redistributions of libraries in ./external are governed by their own licenses: - - - TinyPTC GNU Lesser General Public License - diff --git a/ddc-core-flow.cabal b/ddc-core-flow.cabal --- a/ddc-core-flow.cabal +++ b/ddc-core-flow.cabal @@ -1,5 +1,5 @@ Name: ddc-core-flow -Version: 0.3.2.1 +Version: 0.4.3.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -30,76 +30,117 @@ Library Build-Depends: - base == 4.6.*, - deepseq == 1.3.*, + base >= 4.6 && < 4.10, + array >= 0.4 && < 0.6, + deepseq >= 1.3 && < 1.5, 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.* + limp == 0.3.2.*, + limp-cbc == 0.3.2.*, + transformers == 0.5.*, + mtl == 2.2.1.*, + ddc-core == 0.4.3.*, + ddc-core-salt == 0.4.3.*, + ddc-core-simpl == 0.4.3.*, + ddc-core-tetra == 0.4.3.* 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.Convert.Base + DDC.Core.Flow.Convert.Exp + DDC.Core.Flow.Convert.Type - DDC.Core.Flow.Process.Process DDC.Core.Flow.Process.Operator - DDC.Core.Flow.Process.Pretty - DDC.Core.Flow.Process + DDC.Core.Flow.Process.Process + DDC.Core.Flow.Transform.Rates.Clusters.Base + DDC.Core.Flow.Transform.Rates.Clusters.Greedy + DDC.Core.Flow.Transform.Rates.Clusters.Linear + DDC.Core.Flow.Transform.Rates.Clusters + DDC.Core.Flow.Transform.Rates.CnfFromExp + DDC.Core.Flow.Transform.Rates.Combinators + DDC.Core.Flow.Transform.Rates.Fail + DDC.Core.Flow.Transform.Rates.Graph + DDC.Core.Flow.Transform.Rates.SeriesOfVector + DDC.Core.Flow.Transform.Rates.SizeInference + + DDC.Core.Flow.Transform.Annotate + DDC.Core.Flow.Transform.Concretize + DDC.Core.Flow.Transform.Deannotate + DDC.Core.Flow.Transform.Extract + DDC.Core.Flow.Transform.Forward + DDC.Core.Flow.Transform.Melt DDC.Core.Flow.Transform.Schedule - DDC.Core.Flow.Transform.Prep DDC.Core.Flow.Transform.Slurp - DDC.Core.Flow.Transform.Extract - DDC.Core.Flow.Transform.Concretize DDC.Core.Flow.Transform.Thread + DDC.Core.Flow.Transform.TransformUpX DDC.Core.Flow.Transform.Wind + DDC.Core.Flow.Compounds + DDC.Core.Flow.Context + DDC.Core.Flow.Convert + DDC.Core.Flow.Env + DDC.Core.Flow.Exp + DDC.Core.Flow.Lower + DDC.Core.Flow.Prim + DDC.Core.Flow.Procedure + DDC.Core.Flow.Process + DDC.Core.Flow.Profile + DDC.Core.Flow + Other-modules: + DDC.Core.Flow.Context.Base + DDC.Core.Flow.Context.FillPath + + DDC.Core.Flow.Process.Pretty + DDC.Core.Flow.Prim.Base - DDC.Core.Flow.Prim.KiConFlow - DDC.Core.Flow.Prim.TyConFlow - DDC.Core.Flow.Prim.TyConPrim DDC.Core.Flow.Prim.DaConFlow DDC.Core.Flow.Prim.DaConPrim - DDC.Core.Flow.Prim.OpFlow - DDC.Core.Flow.Prim.OpLoop - DDC.Core.Flow.Prim.OpStore + DDC.Core.Flow.Prim.KiConFlow + DDC.Core.Flow.Prim.OpConcrete + DDC.Core.Flow.Prim.OpControl DDC.Core.Flow.Prim.OpPrim - - DDC.Core.Flow.Transform.Slurp.Operator - DDC.Core.Flow.Transform.Slurp.Alloc + DDC.Core.Flow.Prim.OpSeries + DDC.Core.Flow.Prim.OpStore + DDC.Core.Flow.Prim.OpVector + DDC.Core.Flow.Prim.TyConFlow + DDC.Core.Flow.Prim.TyConPrim - DDC.Core.Flow.Transform.Schedule.SeriesEnv + DDC.Core.Flow.Transform.Schedule.Base + DDC.Core.Flow.Transform.Schedule.Error + DDC.Core.Flow.Transform.Schedule.Kernel + DDC.Core.Flow.Transform.Schedule.Lifting DDC.Core.Flow.Transform.Schedule.Nest + DDC.Core.Flow.Transform.Schedule.Scalar - DDC.Core.Flow.Transform.Extract.Intersperse + DDC.Core.Flow.Transform.Slurp.Context + DDC.Core.Flow.Transform.Slurp.Error + DDC.Core.Flow.Transform.Slurp.Operator + DDC.Core.Flow.Transform.Slurp.Resize + DDC.Core.Flow.Exp.Simple.Collect + DDC.Core.Flow.Exp.Simple.Compounds + DDC.Core.Flow.Exp.Simple.Exp + GHC-options: + -Wall -fno-warn-orphans -fno-warn-missing-signatures + -fno-warn-missing-methods -fno-warn-unused-do-bind Extensions: - KindSignatures NoMonomorphismRestriction + FunctionalDependencies + MultiParamTypeClasses + FlexibleContexts ScopedTypeVariables StandaloneDeriving - PatternGuards - ParallelListComp DeriveDataTypeable + FlexibleInstances + ParallelListComp + KindSignatures + PatternGuards ViewPatterns - + BangPatterns