packages feed

ddc-core-flow 0.3.2.1 → 0.4.3.1

raw patch · 73 files changed

Files

DDC/Core/Flow.hs view
@@ -6,11 +6,27 @@         ( -- * Language profile           profile +          -- * Driver+        , Lifting       (..)+        , Config        (..)+        , defaultConfigVector+        , defaultConfigKernel+        , defaultConfigScalar+        , Method        (..)+        , lowerModule+           -- * Names         , Name          (..)+        , KiConFlow     (..)         , TyConFlow     (..)+        , DaConFlow     (..)+        , OpControl     (..)+        , OpSeries      (..)+        , OpStore       (..)+        , OpVector      (..)         , PrimTyCon     (..)         , PrimArith     (..)+        , PrimVec       (..)         , PrimCast      (..)            -- * Name Parsing@@ -23,3 +39,4 @@ where import DDC.Core.Flow.Prim import DDC.Core.Flow.Profile+import DDC.Core.Flow.Lower
DDC/Core/Flow/Compounds.hs view
@@ -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
DDC/Core/Flow/Context.hs view
@@ -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
+ DDC/Core/Flow/Context/Base.hs view
@@ -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++
+ DDC/Core/Flow/Context/FillPath.hs view
@@ -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@.+--   +
+ DDC/Core/Flow/Convert.hs view
@@ -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'+
+ DDC/Core/Flow/Convert/Base.hs view
@@ -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."]+
+ DDC/Core/Flow/Convert/Exp.hs view
@@ -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 ]+
+ DDC/Core/Flow/Convert/Type.hs view
@@ -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"+
DDC/Core/Flow/Env.hs view
@@ -32,52 +32,57 @@ primDataDefs :: DataDefs Name primDataDefs  = fromListDataDefs-        -- Primitive ------------------------------------------------ $      -- Bool#-        [ DataDef (NamePrimTyCon PrimTyConBool) + $      -- Primitive -----------------------------------------------+        -- Bool#+        [ makeDataDefAlg (NamePrimTyCon PrimTyConBool)                  []                  (Just   [ (NameLitBool True,  [])                          , (NameLitBool False, []) ])          -- Nat#-        , DataDef (NamePrimTyCon PrimTyConNat)  [] Nothing+        , makeDataDefAlg (NamePrimTyCon PrimTyConNat)        [] Nothing          -- Int#-        , DataDef (NamePrimTyCon PrimTyConInt)  [] Nothing+        , makeDataDefAlg (NamePrimTyCon PrimTyConInt)        [] Nothing +        -- Float32#+        , makeDataDefAlg (NamePrimTyCon (PrimTyConFloat 32)) [] Nothing++        -- Float64#+        , makeDataDefAlg (NamePrimTyCon (PrimTyConFloat 64)) [] Nothing+         -- WordN#-        , DataDef (NamePrimTyCon (PrimTyConWord 64)) [] Nothing-        , DataDef (NamePrimTyCon (PrimTyConWord 32)) [] Nothing-        , DataDef (NamePrimTyCon (PrimTyConWord 16)) [] Nothing-        , DataDef (NamePrimTyCon (PrimTyConWord 8))  [] Nothing+        , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 64))  [] Nothing+        , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 32))  [] Nothing+        , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 16))  [] Nothing+        , makeDataDefAlg (NamePrimTyCon (PrimTyConWord 8))   [] Nothing           -- Flow ------------------------------------------------------         -- Vector-        , DataDef+        , makeDataDefAbs                 (NameTyConFlow TyConFlowVector)-                [kRate, kData]-                (Just   [])+                [BAnon kRate, BAnon kData]          -- Series-        , DataDef+        , makeDataDefAbs                 (NameTyConFlow TyConFlowSeries)-                [kRate, kData]-                (Just   [])+                [BAnon kRate, BAnon kData]         ]          -- Tuple         -- Hard-code maximum tuple arity to 32.- ++     [ makeTupleDataDef arity        | arity <- [2..32] ]+        -- We don't have a way of avoiding the upper bound.+ ++     [ makeTupleDataDef arity+                | arity <- [2..32] ]   -- | Make a tuple data def for the given tuple arity. makeTupleDataDef :: Int -> DataDef Name makeTupleDataDef n-        = DataDef+        = makeDataDefAlg                 (NameTyConFlow (TyConFlowTuple n))-                (replicate n kData)+                (replicate n (BAnon kData))                 (Just   [ ( NameDaConFlow (DaConFlowTuple n)                           , (reverse [tIx kData i | i <- [0..n - 1]]))]) @@ -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
DDC/Core/Flow/Exp.hs view
@@ -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++
+ DDC/Core/Flow/Exp/Simple/Collect.hs view
@@ -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+
+ DDC/Core/Flow/Exp/Simple/Compounds.hs view
@@ -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
+ DDC/Core/Flow/Exp/Simple/Exp.hs view
@@ -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+
+ DDC/Core/Flow/Lower.hs view
@@ -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+
DDC/Core/Flow/Prim.hs view
@@ -18,21 +18,31 @@         , readDaConFlow         , typeDaConFlow -          -- * Flow operators-        , OpFlow        (..)-        , readOpFlow-        , typeOpFlow+          -- * Fusable Flow operators+        , OpConcrete    (..)+        , readOpConcrete+        , typeOpConcrete -          -- * Loop operators-        , OpLoop        (..)-        , readOpLoop-        , typeOpLoop+          -- * Series operators+        , OpSeries      (..)+        , readOpSeries+        , typeOpSeries +          -- * Control operators+        , OpControl     (..)+        , readOpControl+        , typeOpControl+           -- * Store operators         , OpStore       (..)         , readOpStore         , typeOpStore +          -- * Store operators+        , OpVector      (..)+        , readOpVector+        , typeOpVector+           -- * Primitive type constructors         , PrimTyCon     (..)         , kindPrimTyCon@@ -41,6 +51,13 @@         , PrimArith     (..)         , typePrimArith +          -- * Primitive vector operators+        , PrimVec    (..)+        , typePrimVec+        , multiOfPrimVec+        , liftPrimArithToVec+        , lowerPrimVecToArith+           -- * Casting between primitive types         , PrimCast      (..)         , typePrimCast)@@ -51,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.
DDC/Core/Flow/Prim/Base.hs view
@@ -4,17 +4,21 @@         , KiConFlow     (..)         , TyConFlow     (..)         , DaConFlow     (..)-        , OpFlow        (..)-        , OpLoop        (..)+        , OpConcrete    (..)+        , OpControl     (..)+        , OpSeries      (..)         , OpStore       (..)+        , OpVector      (..)         , PrimTyCon     (..)         , PrimArith     (..)+        , PrimVec       (..)         , PrimCast      (..)) where import Data.Typeable-import DDC.Core.Salt.Name +import DDC.Core.Salt.Name         ( PrimTyCon     (..)         , PrimArith     (..)+        , PrimVec       (..)         , PrimCast      (..))  @@ -39,16 +43,22 @@         -- | Fragment specific data constructors.         | NameDaConFlow         DaConFlow -        -- | Flow operators.-        | NameOpFlow            OpFlow+        -- | Concrete series operators.+        | NameOpConcrete        OpConcrete -        -- | Loop operators.-        | NameOpLoop            OpLoop+        -- | Control operators.+        | NameOpControl         OpControl +        -- | Series operators.+        | NameOpSeries          OpSeries+         -- | Store operators.         | NameOpStore           OpStore +        -- | Vector operators.+        | NameOpVector          OpVector +         -- Machine primitives ------------------         -- | A primitive type constructor.         | NamePrimTyCon         PrimTyCon@@ -59,7 +69,10 @@         -- | Primitive casting between numeric types.         | NamePrimCast          PrimCast +        -- | Primitive vector operators.+        | NamePrimVec           PrimVec +         -- Literals -----------------------------         -- | A boolean literal.         | NameLitBool           Bool@@ -70,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)
DDC/Core/Flow/Prim/DaConFlow.hs view
@@ -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
DDC/Core/Flow/Prim/DaConPrim.hs view
@@ -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))
DDC/Core/Flow/Prim/KiConFlow.hs view
@@ -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)
+ DDC/Core/Flow/Prim/OpConcrete.hs view
@@ -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))+
+ DDC/Core/Flow/Prim/OpControl.hs view
@@ -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))+
− DDC/Core/Flow/Prim/OpFlow.hs 
@@ -1,252 +0,0 @@--module DDC.Core.Flow.Prim.OpFlow-        ( readOpFlow-        , typeOpFlow-        , xRateOfSeries-        , xNatOfRateNat)-where-import DDC.Core.Flow.Prim.KiConFlow-import DDC.Core.Flow.Prim.TyConFlow-import DDC.Core.Flow.Prim.TyConPrim-import DDC.Core.Flow.Prim.Base-import DDC.Core.Transform.LiftT-import DDC.Core.Compounds.Simple-import DDC.Core.Exp.Simple-import DDC.Base.Pretty-import Control.DeepSeq-import Data.List-import Data.Char        ---instance NFData OpFlow---instance Pretty OpFlow where- ppr pf-  = case pf of-        OpFlowVectorOfSeries    -> text "vectorOfSeries"        <> text "#"-        OpFlowRateOfSeries      -> text "rateOfSeries"          <> text "#"-        OpFlowNatOfRateNat      -> text "natOfRateNat"          <> text "#"--        OpFlowMkSel 1           -> text "mkSel"                 <> text "#"-        OpFlowMkSel n           -> text "mkSel"      <> int n   <> text "#"--        OpFlowMap 1             -> text "map"                   <> text "#"-        OpFlowMap i             -> text "map"        <> int i   <> text "#"--        OpFlowRep               -> text "rep"                   <> text "#"-        OpFlowReps              -> text "reps"                  <> text "#"--        OpFlowFold              -> text "fold"                  <> text "#"-        OpFlowFoldIndex         -> text "foldIndex"             <> text "#"-        OpFlowFolds             -> text "folds"                 <> text "#"--        OpFlowUnfold            -> text "unfold"                <> text "#"-        OpFlowUnfolds           -> text "unfolds"               <> text "#"--        OpFlowSplit   i         -> text "split"      <> int i   <> text "#"-        OpFlowCombine i         -> text "combine"    <> int i   <> text "#"--        OpFlowPack              -> text "pack"                  <> text "#"----- | Read a data flow operator name.-readOpFlow :: String -> Maybe OpFlow-readOpFlow str-        | Just rest     <- stripPrefix "mkSel" str-        , (ds, "#")     <- span isDigit rest-        , not $ null ds-        , arity         <- read ds-        , arity == 1-        = Just $ OpFlowMkSel arity--        | Just rest     <- stripPrefix "map" str-        , (ds, "#")     <- span isDigit rest-        , not $ null ds-        , arity         <- read ds-        = Just $ OpFlowMap arity--        | Just rest     <- stripPrefix "split" str-        , (ds, "#")     <- span isDigit rest-        , not $ null ds-        , arity         <- read ds-        = Just $ OpFlowSplit arity--        | Just rest     <- stripPrefix "combine" str-        , (ds, "#")     <- span isDigit rest-        , not $ null ds-        , arity         <- read ds-        = Just $ OpFlowCombine arity--        | otherwise-        = case str of-                "vectorOfSeries#"  -> Just $ OpFlowVectorOfSeries-                "rateOfSeries#"    -> Just $ OpFlowRateOfSeries-                "natOfRateNat#"    -> Just $ OpFlowNatOfRateNat-                "mkSel#"           -> Just $ OpFlowMkSel 1-                "map#"             -> Just $ OpFlowMap   1-                "rep#"             -> Just $ OpFlowRep-                "reps#"            -> Just $ OpFlowReps-                "fold#"            -> Just $ OpFlowFold-                "foldIndex#"       -> Just $ OpFlowFoldIndex-                "folds#"           -> Just $ OpFlowFolds-                "unfold#"          -> Just $ OpFlowUnfold-                "unfolds#"         -> Just $ OpFlowUnfolds-                "pack#"            -> Just $ OpFlowPack-                _                  -> Nothing----- Types -------------------------------------------------------------------------- | Yield the type of a data flow operator, ---   or `error` if there isn't one.-typeOpFlow :: OpFlow -> Type Name-typeOpFlow op- = case takeTypeOpFlow op of-        Just t  -> t-        Nothing -> error $ "ddc-core-flow.typeOpFlow: invalid op " ++ show op----- | Yield the type of a data flow operator.-takeTypeOpFlow :: OpFlow -> Maybe (Type Name)-takeTypeOpFlow op- = case op of-        -- Series Conversions --------------------        -- vectorOfSeries# :: [k : Rate]. [a : Data]-        --                 .  Series k a -> Vector a-        OpFlowVectorOfSeries-         -> Just $ tForalls [kRate, kData] $ \[tK, tA] -                -> tSeries tK tA `tFun` tVector tA--        -- rateOfSeries#   :: [k : Rate]. [a : Data]-        --                 .  Series k a -> RateNat k-        OpFlowRateOfSeries -         -> Just $ tForalls [kRate, kData] $ \[tK, tA]-                -> tSeries tK tA `tFun` tRateNat tK--        -- natOfRateNat#   :: [k : Rate]. RateNat k -> Nat#-        OpFlowNatOfRateNat -         -> Just $ tForall kRate $ \tK -                -> tRateNat tK `tFun` tNat---        -- Selectors -----------------------------        -- mkSel1#    :: [k1 : Rate]. [a : Data]-        --            .  Series k1 Bool#-        --            -> ([k2 : Rate]. Sel1 k1 k2 -> a)-        --            -> a-        OpFlowMkSel 1-         -> Just $ tForalls [kRate, kData] $ \[tK1, tA]-                ->       tSeries tK1 tBool-                `tFun` (tForall kRate $ \tK2 -                                -> tSel1 (liftT 1 tK1) tK2 `tFun` (liftT 1 tA))-                `tFun` tA--  -        -- Maps ----------------------------------        -- map   :: [k : Rate] [a b : Data]-        --       .  (a -> b) -> Series k a -> Series k b-        OpFlowMap 1-         -> Just $ tForalls [kRate, kData, kData] $ \[tK, tA, tB]-                ->       (tA `tFun` tB)-                `tFun` tSeries tK tA-                `tFun` tSeries tK tB--        -- mapN  :: [k : Rate] [a0..aN : Data]-        --       .  (a0 -> .. aN) -> Series k a0 -> .. Series k aN-        OpFlowMap n-         | n >= 2-         , Just tWork <- tFunOfList   -                         [ TVar (UIx i) -                                | i <- reverse [0..n] ]--         , Just tBody <- tFunOfList-                         (tWork : [tSeries (TVar (UIx (n + 1))) (TVar (UIx i)) -                                | i <- reverse [0..n] ])--         -> Just $ foldr TForall tBody-                         [ BAnon k | k <- kRate : replicate (n + 1) kData ]---        -- Replicates --------------------------        -- rep  :: [a : Data] [k : Rate]-        --      .  a -> Series k a-        OpFlowRep -         -> Just $ tForalls [kData, kRate] $ \[tA, tR]-                -> tA `tFun` tSeries tR tA--        -- reps  :: [k1 k2 : Rate]. [a : Data]-        --       .  Segd   k1 k2 -        --       -> Series k1 a-        --       -> Series k2 a-        OpFlowReps -         -> Just $ tForalls [kRate, kRate, kData] $ \[tK1, tK2, tA]-                ->     tSegd   tK1 tK2-                `tFun` tSeries tK1 tA-                `tFun` tSeries tK2 tA---        -- Folds ---------------------------------        -- fold :: [k : Rate]. [a b: Data]-        --      .  (a -> b -> a) -> a -> Series k b -> a-        OpFlowFold    -         -> Just $ tForalls [kRate, kData, kData] $ \[tK, tA, tB]-                ->     (tA `tFun` tB `tFun` tA)-                `tFun` tA-                `tFun` tSeries tK tB-                `tFun` tA--        -- foldIndex :: [k : Rate]. [a b: Data]-        --           .  (Int# -> a -> b -> a) -> a -> Series k b -> a-        OpFlowFoldIndex-         -> Just $ tForalls [kRate, kData, kData] $ \[tK, tA, tB]-                 ->     (tInt `tFun` tA `tFun` tB `tFun` tA)-                 `tFun` tA-                 `tFun` tSeries tK tB-                 `tFun` tA--        -- folds :: [k1 k2 : Rate]. [a b: Data]-        --       .  Segd   k1 k2 -        --       -> (a -> b -> a)       -- fold operator-        --       -> Series k1 a         -- start values-        --       -> Series k2 b         -- source elements-        --       -> Series k1 a         -- result values-        OpFlowFolds-         -> Just $ tForalls [kRate, kRate, kData, kData] $ \[tK1, tK2, tA, tB]-                 ->      tSegd tK1 tK2-                 `tFun` (tInt `tFun` tA `tFun` tB `tFun` tA)-                 `tFun` tSeries tK1 tA-                 `tFun` tSeries tK2 tB-                 `tFun` tSeries tK1 tA---        -- Packs ---------------------------------        -- pack  :: [k1 k2 : Rate]. [a : Data]-        --       .  Sel2 k1 k2-        --       -> Series k1 a -> Series k2 a-        OpFlowPack-         -> Just $ tForalls [kRate, kRate, kData] $ \[tK1, tK2, tA]-                ->     tSel1   tK1 tK2 -                `tFun` tSeries tK1 tA-                `tFun` tSeries tK2 tA--        _ -> Nothing----- Compounds -------------------------------------------------------------------xRateOfSeries :: Type Name -> Type Name -> Exp () Name -> Exp () Name-xRateOfSeries tK tA xS -         = xApps  (xVarOpFlow OpFlowRateOfSeries) -                  [XType tK, XType tA, xS]---xNatOfRateNat :: Type Name -> Exp () Name -> Exp () Name-xNatOfRateNat tK xR-        = xApps  (xVarOpFlow OpFlowNatOfRateNat)-                 [XType tK, xR]----- Utils ------------------------------------------------------------------------xVarOpFlow :: OpFlow -> Exp () Name-xVarOpFlow op-        = XVar  (UPrim (NameOpFlow op) (typeOpFlow op))-
− DDC/Core/Flow/Prim/OpLoop.hs 
@@ -1,84 +0,0 @@---- | Loop related names.-module DDC.Core.Flow.Prim.OpLoop-        ( readOpLoop-        , typeOpLoop-        , xLoopLoopN-        , xLoopGuard)-where-import DDC.Core.Flow.Prim.KiConFlow-import DDC.Core.Flow.Prim.TyConPrim-import DDC.Core.Flow.Prim.TyConFlow-import DDC.Core.Flow.Prim.Base-import DDC.Core.Compounds.Simple-import DDC.Core.Exp.Simple-import DDC.Base.Pretty-import Control.DeepSeq---instance NFData OpLoop---instance Pretty OpLoop where- ppr fo-  = case fo of-        OpLoopLoop      -> text "loop#"-        OpLoopLoopN     -> text "loopn#"--        OpLoopGuard     -> text "guard#"----- | Read a loop operator name.-readOpLoop :: String -> Maybe OpLoop-readOpLoop str- = case str of-        "loop#"         -> Just $ OpLoopLoop-        "loopn#"        -> Just $ OpLoopLoopN-        "guard#"        -> Just $ OpLoopGuard-        _               -> Nothing----- Types ------------------------------------------------------------------------- | Yield the type of a loop operator.-typeOpLoop  :: OpLoop -> Type Name-typeOpLoop op- = case op of-        -- loop#  :: [k : Rate]. (Nat# -> Unit) -> Unit-        OpLoopLoop-         -> tForall kRate -         $  \_ -> (tNat `tFun` tUnit) `tFun` tUnit--        -- loopn#  :: [k : Rate]. RateNat k -> (Nat# -> Unit) -> Unit-        OpLoopLoopN-         -> tForall kRate -         $  \kR -> tRateNat kR `tFun` (tNat `tFun` tUnit) `tFun` tUnit--        -- guard#  :: Ref# Nat# -> Bool# -        --         -> (Nat# -> Unit) -> Unit-        OpLoopGuard -         -> tRef tNat-                `tFun` tBool-                `tFun` (tNat `tFun` tUnit)-                `tFun` tUnit----- Compounds -------------------------------------------------------------------xLoopLoopN :: Type Name -> Exp () Name -> Exp () Name -> Exp () Name-xLoopLoopN tR xRN xF -         = xApps (xVarOpLoop OpLoopLoopN) [XType tR, xRN, xF]---xLoopGuard -        :: Exp () Name  -- ^ Reference to guard counter.-        -> Exp () Name  -- ^ Boolean flag to test.-        -> Exp () Name  -- ^ Body of guard.-        -> Exp () Name--xLoopGuard xB xCount xF-        = xApps (xVarOpLoop OpLoopGuard) [xCount, xB, xF]----- Utils ------------------------------------------------------------------------xVarOpLoop :: OpLoop -> Exp () Name-xVarOpLoop op-        = XVar (UPrim (NameOpLoop op) (typeOpLoop op))
DDC/Core/Flow/Prim/OpPrim.hs view
@@ -1,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))+
+ DDC/Core/Flow/Prim/OpSeries.hs view
@@ -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))+
DDC/Core/Flow/Prim/OpStore.hs view
@@ -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 ----------------------------------------------------------------------
+ DDC/Core/Flow/Prim/OpVector.hs view
@@ -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+
DDC/Core/Flow/Prim/TyConFlow.hs view
@@ -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 ----------------------------------------------------------------------
DDC/Core/Flow/Prim/TyConPrim.hs view
@@ -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
DDC/Core/Flow/Procedure.hs view
@@ -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-
DDC/Core/Flow/Process.hs view
@@ -1,6 +1,7 @@  module DDC.Core.Flow.Process         ( Process       (..)+         , Operator      (..)) where import DDC.Core.Flow.Process.Process
DDC/Core/Flow/Process/Operator.hs view
@@ -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
DDC/Core/Flow/Process/Pretty.hs view
@@ -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) ]++
DDC/Core/Flow/Process/Process.hs view
@@ -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         }
DDC/Core/Flow/Profile.hs view
@@ -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.
+ DDC/Core/Flow/Transform/Annotate.hs view
@@ -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++
DDC/Core/Flow/Transform/Concretize.hs view
@@ -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
+ DDC/Core/Flow/Transform/Deannotate.hs view
@@ -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+
DDC/Core/Flow/Transform/Extract.hs view
@@ -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) ]
− DDC/Core/Flow/Transform/Extract/Intersperse.hs 
@@ -1,53 +0,0 @@--module DDC.Core.Flow.Transform.Extract.Intersperse-        (intersperseStmts)-where-import DDC.Core.Flow.Compounds-import DDC.Core.Flow.Prim-import DDC.Core.Flow.Exp-import DDC.Core.Collect-import DDC.Core.Transform.Annotate-import DDC.Type.Env-import Data.List (partition, (\\))-import qualified Data.Set as Set----- | Given two lists of lets, order them so that any variables are bound before use.-intersperseStmts :: [LetsF] -> [LetsF] -> [LetsF]-intersperseStmts ls rs- = let bls = nubbish $ map takeSubstBoundsOfBinds $ map valwitBindsOfLets ls-       brs = nubbish $ map takeSubstBoundsOfBinds $ map valwitBindsOfLets rs-   in  intersperse' (ls `zip` bls ++ rs `zip` brs)----- Because a name might be bound a couple of times --- (see extractStmtEnd:EndVecSlice)-nubbish :: [[Bound Name]] -> [[Bound Name]]-nubbish bs' = go bs' []- where  go [] _        = []-        go (b:bs) accs = (b \\ accs) : go bs (accs ++ b)---intersperse' -        :: [(Lets () Name, [Bound Name])]-        -> [Lets () Name]--intersperse' [] = []--intersperse' ((x,b):bxs)- -- Check if any of the free variables in x are bound later on.- -- If so, defer this binding...- | f            <- freeXLets x- , (r:rs,os)    <- partition (any (flip Set.member f) . snd) bxs- , (x', _)     <- r- = x' : intersperse' (rs ++ (x, b) : os)-- -- Otherwise it's a valid binding- | otherwise- = x : intersperse' bxs---freeXLets :: LetsF -> Set.Set (Bound Name)-freeXLets ll- = freeX empty $ annotate () (XLet ll (XCon (dcBool True)))-
+ DDC/Core/Flow/Transform/Forward.hs view
@@ -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+
+ DDC/Core/Flow/Transform/Melt.hs view
@@ -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)+
− DDC/Core/Flow/Transform/Prep.hs 
@@ -1,169 +0,0 @@--module DDC.Core.Flow.Transform.Prep-        (prepModule)-where-import DDC.Core.Flow.Prim-import DDC.Core.Flow.Prim.TyConPrim-import DDC.Core.Compounds-import DDC.Core.Module-import DDC.Core.Exp-import Control.Monad.State.Strict-import Data.Map                 (Map)-import qualified Data.Map       as Map-import DDC.Type.Env             (TypeEnv)-import qualified DDC.Type.Env   as Env----- | Prepare a module for lowering.---   We need all worker functions passed to flow operators to be eta-expanded---   and for their parameters to have real names.-prepModule -        ::  Module a Name -        -> (Module a Name, Map Name [Type Name])--prepModule mm- = do   runState (prepModuleM mm) Map.empty---prepModuleM :: Module a Name -> PrepM (Module a Name)-prepModuleM mm- = do   xBody'  <- prepX Env.empty $ moduleBody mm-        return  $  mm { moduleBody = xBody' }----- Do a bottom-up rewrite,---  on the way up remember names of variables that are passed as workers ---  to flow operators, then eta-expand bindings with those names.--- Record the environment of let-bound expressions, to know whether to ---  eta-expand in their definition or at the callsite.-prepX   :: TypeEnv Name -> Exp a Name -> PrepM (Exp a Name)-prepX tenv xx- = let down     = prepX tenv-   in  case xx of-        -- MapN-        XApp{}-         | Just (XVar _ u, xsArgs)              <- takeXApps xx-         , UPrim (NameOpFlow (OpFlowMap n)) _   <- u-         , _xTR : xsArgs2                       <- xsArgs-         , (xsA, xsArgs3)                       <- splitAt (n + 1) xsArgs2-         , tsA                                  <- [t | XType t <- xsA]-         , XVar _ (UName nWorker) : _           <- xsArgs3-         , Env.member (UName nWorker) tenv-         -> do  addWorkerArgs nWorker (take n tsA)-                return xx--        -- Worker passed to map, but not let-bound.-        -- Eta-expand in-place.-        XApp{}-         | Just (xmap@(XVar _ u), args@[_,  XType tA, XType _tB, f@(XVar a _), _])-                                                <- takeXApps xx-         , UPrim (NameOpFlow (OpFlowMap 1)) _   <- u-         -> do  let f'    = xEtaExpand a f [tA]-                    args' = take 3 args ++ [f'] ++ [last args]-                return $ xApps a xmap args'--        -- Detect workers passed to folds.-        XApp{}-         | Just (XVar _ u, [_, XType tA, XType tB, XVar _ (UName n), _, _])-                                               <- takeXApps xx-         , UPrim (NameOpFlow OpFlowFold) _     <- u-         -> do   addWorkerArgs n [tA, tB]-                 return xx--        -- FoldIndex-        XApp{}-         | Just (XVar _ u, [_, XType tA, XType tB, XVar _ (UName n), _, _])-                                                <- takeXApps xx-         , UPrim (NameOpFlow OpFlowFoldIndex) _ <- u-         -> do   addWorkerArgs n [tInt, tA, tB]-                 return xx--        -- Detect workers passed to mkSels-        XApp{}-         | Just (XVar _ u, [XType _tK1, XType _tA, _, XVar _ (UName n)])-                                                <- takeXApps xx-         , UPrim (NameOpFlow (OpFlowMkSel _)) _ <- u-         -> do  addWorkerArgs n []-                return xx--        -- Bottom-up transform boilerplate.-        XVar{}          -> return xx-        XCon{}          -> return xx-        XLAM  a b x     -> liftM3 XLAM  (return a) (return b) (down x)-        XLam  a b x     -> liftM3 XLam  (return a) (return b) (down x)-        XApp  a x1 x2   -> liftM3 XApp  (return a) (down x1)  (down x2)--        XLet  a lts x   -         -> do  -- Slurp binds from lets, add to tenv-                let tenv' = Env.extends (valwitBindsOfLets lts) tenv-                x'      <- prepX tenv' x--                -- Use old tenv for the binders-                lts'    <- prepLts tenv a lts-                return  $  XLet a lts' x'--        XCase a x alts  -> liftM3 XCase (return a) (down x)   (mapM (prepAlt tenv) alts)-        XCast a c x     -> liftM3 XCast (return a) (return c) (down x)-        XType{}         -> return xx-        XWitness{}      -> return xx----- Prepare let bindings for lowering.-prepLts :: TypeEnv Name -> a -> Lets a Name -> PrepM (Lets a Name)-prepLts tenv a lts- = case lts of-        LLet b@(BName n _) x-         -> do  x'      <- prepX tenv x--                mArgs   <- lookupWorkerArgs n-                case mArgs of-                 Just tsArgs-                  |  length tsArgs > 0-                   -> return $ LLet b $ xEtaExpand a x' tsArgs--                 _ -> return $ LLet b x'--        LLet b x-         -> do  x'      <- prepX tenv x-                return  $ LLet b x'--        LRec bxs-         -> do  let (bs, xs) = unzip bxs-                let tenv'    = Env.extends bs tenv-                xs'     <- mapM (prepX tenv') xs-                return  $ LRec $ zip bs xs'--        LLetRegions{}   -> return lts-        LWithRegion{}   -> return lts----- Prepare case alternative for lowering.-prepAlt :: TypeEnv Name -> Alt a Name -> PrepM (Alt a Name)-prepAlt tenv (AAlt w x)-        = liftM (AAlt w) (prepX tenv x)---xEtaExpand :: a -> Exp a Name -> [Type Name] -> Exp a Name-xEtaExpand a x tys- = xLams a    (map BAnon tys)- $ xApps a x  [ XVar a (UIx (length tys - 1 - ix))-              | ix <- [0 ..  length tys - 1] ]----- State -----------------------------------------------------------------------type PrepS      = Map   Name [Type Name]-type PrepM      = State PrepS----- | Record this name as being of a worker function.-addWorkerArgs   :: Name -> [Type Name] -> PrepM ()-addWorkerArgs name tsParam-        = modify $ Map.insert name tsParam----- | Check whether this name corresponds to a worker function.-lookupWorkerArgs    :: Name -> PrepM (Maybe [Type Name])-lookupWorkerArgs name- = do   names   <- get-        return  $ Map.lookup name names-
+ DDC/Core/Flow/Transform/Rates/Clusters.hs view
@@ -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+
+ DDC/Core/Flow/Transform/Rates/Clusters/Base.hs view
@@ -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++
+ DDC/Core/Flow/Transform/Rates/Clusters/Greedy.hs view
@@ -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+
+ DDC/Core/Flow/Transform/Rates/Clusters/Linear.hs view
@@ -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"+
+ DDC/Core/Flow/Transform/Rates/CnfFromExp.hs view
@@ -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+
+ DDC/Core/Flow/Transform/Rates/Combinators.hs view
@@ -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
+ DDC/Core/Flow/Transform/Rates/Fail.hs view
@@ -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)+
+ DDC/Core/Flow/Transform/Rates/Graph.hs view
@@ -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+
+ DDC/Core/Flow/Transform/Rates/SeriesOfVector.hs view
@@ -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) "'"++
+ DDC/Core/Flow/Transform/Rates/SizeInference.hs view
@@ -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++
DDC/Core/Flow/Transform/Schedule.hs view
@@ -1,252 +1,13 @@  module DDC.Core.Flow.Transform.Schedule-        (scheduleProcess)-where-import DDC.Core.Flow.Transform.Schedule.SeriesEnv-import DDC.Core.Flow.Transform.Schedule.Nest-import DDC.Core.Flow.Procedure-import DDC.Core.Flow.Process-import DDC.Core.Flow.Compounds-import DDC.Core.Flow.Prim-import DDC.Core.Flow.Exp-import DDC.Base.Pretty-import Control.Monad----- | Create loops from a list of operators.------   * The input series must all have the same rate.----scheduleProcess :: Process -> Procedure-scheduleProcess -        (Process -                { processName           = name-                , processParamTypes     = psType-                , processParamValues    = psValue-                , processContexts       = contexts-                , processOperators      = ops -                , processStmts          = stmts-                , processResultType     = tResult-                , processResult         = xResult})-  = let-        -- Create all the contexts, starting with an empty loop nest.-        Just nest1      = foldM insertContext NestEmpty contexts--        -- Schedule the series operators into the nest.-        nest2           = scheduleOperators nest1 emptySeriesEnv ops--    in  Procedure-                { procedureName         = name-                , procedureParamTypes   = psType-                , procedureParamValues  = psValue-                , procedureNest         = nest2-                , procedureStmts        = stmts-                , procedureResultType   = tResult-                , procedureResult       = xResult }------------------------------------------------------------------------------------- | Schedule some series operators into a loop nest.-scheduleOperators -        :: Nest         -- ^ The starting loop nest.-        -> SeriesEnv    -- ^ Series environment maps series binds to elem binds.-        -> [Operator]   -- ^ The operators to schedule.-        -> Nest--scheduleOperators nest0 env ops- = case ops of-        [] -> nest0-        op : ops'     -           -> let (env', nest')   = scheduleOperator nest0 env op-              in  scheduleOperators nest' env' ops'----- | Schedule a single series operator into a loop nest.-scheduleOperator -        :: Nest         -- ^ The current loop nest-        -> SeriesEnv    -- ^ Series environment maps series binds to elem binds.-        -> Operator     -- ^ Operator to schedule.-        -> (SeriesEnv, Nest)--scheduleOperator nest0 env op-- -- Id -------------------------------------------- | OpId{}     <- op- = let-        -- Get binders for the input elements.-        Just nSeries-         = takeNameOfBound (opInputSeries op)--        (uInput, env1, nest1)-         = bindNextElem nSeries-                        (opInputRate op) (opElemType op)-                        env nest0--        Just bResultElem     -         = elemBindOfSeriesBind $ opResultSeries op--        context         = ContextRate (opInputRate op)--        Just nest2      = insertBody nest1 context-                        $ [ BodyStmt bResultElem (XVar uInput) ]--   in   (env1, nest2)--- -- Create ---------------------------------------- | OpCreate{} <- op- = let  -        -- Get binders for the input elements.-        Just nSeries    -         = takeNameOfBound (opInputSeries op)-        -        (uInput, env1, nest1)-         = bindNextElem nSeries -                        (opInputRate op) (opElemType  op)-                        env nest0--        -- Insert statements that allocate the vector.-        --  We use the type-level series rate to describe the length of-        --  the vector. This will be repalced by a RateNat value during-        --  the concretization phase.-        BName nVec _    = opResultVector op-        context         = ContextRate (opInputRate op)--        -- Rate we're using to allocate the result vector.-        --   This will be larger than the actual result series rate if we're-        --   creating a vector inside a selector context.-        Just tRateAlloc = opAllocRate op--        Just nest2      = insertStarts nest1 context-                        $ [ StartVecNew  -                                nVec                    -- allocated vector-                                (opElemType op)         -- elem type-                                tRateAlloc ]            -- allocation rate--        -- Insert statements that write the current element to the vector.-        Just nest3      = insertBody   nest2 context -                        $ [ BodyVecWrite -                                nVec                    -- destination vector-                                (opElemType op)         -- elem type-                                (XVar (UIx 0))          -- index-                                (XVar uInput) ]         -- value--        -- Slice the vector at the end-        Just nest4      = insertEnds   nest3 context -                        $ [ EndVecSlice-                                nVec                    -- destination vector-                                (opElemType op)         -- elem type-                                (opInputRate op) ]      -- index--        -- But only slice it if the input rate is different to output rate-        nest'           = if   opInputRate op == tRateAlloc-                          then nest3-                          else nest4-   in   (env1, nest')-- - -- Maps ------------------------------------------ | OpMap{} <- op- = let  -        -- Get binders for the input elements.-        Just nsSeries   = sequence $ map takeNameOfBound $ opInputSeriess op-        tsRate          = repeat (opInputRate op)-        tsElem          = map typeOfBind $ opWorkerParams op--        (usInputs, env1, nest1)    -                        = bindNextElems (zip3 nsSeries tsRate tsElem) env nest0--        -- Variables for all the input elements.-        xsInputs        = map XVar usInputs--        -- Substitute input element vars into the worker body.-        xBody           = foldl (\x (b, p) -> XApp (XLam b x) p)-                                (opWorkerBody op)-                                (zip (opWorkerParams op) xsInputs)--        -- Binder for a single result element in the series context.-        Just nResultSeries = takeNameOfBind $ opResultSeries op-        nResultElem     = NameVarMod nResultSeries "elem"-        uResultElem     = UName nResultElem--        Just bResultElem   = elemBindOfSeriesBind (opResultSeries op)--        -- Insert the expression that computes the new result into the nest.-        context         = ContextRate $ opInputRate op-        Just nest2      = insertBody nest1 context-                        $ [ BodyStmt bResultElem xBody ]--        -- Associate the variable for the result element with the result series.-        env2            = insertElemForSeries nResultSeries uResultElem env1--    in  (env2, nest2)--- -- Folds ---------------------------------------- | OpFold{} <- op- = let  -        -- Lookup binders for the input elements.-        Just nSeries    = takeNameOfBound (opInputSeries op)-        tRate           = opInputRate op-        tInputElem      = typeOfBind (opWorkerParamElem op)-        (uInput, env1, nest1)-                        = bindNextElem nSeries tRate tInputElem env nest0--        -- Make a name for the accumulator.-        BName nResult _ = opResultValue op-        nAcc            = NameVarMod nResult "acc"--        -- Type of the accumulator.-        tAcc            = typeOfBind (opWorkerParamAcc op)-        -        -- Insert statements that initialize the starting value-        --  of the accumulator.-        context         = ContextRate $ opInputRate op-        Just nest2      = insertStarts nest1 context-                        $ [ StartAcc nAcc tAcc (opZero op) ]--        -- Substitute input and accumulator vars into worker body.-        xBody           = XApp  (XApp   ( XLam (opWorkerParamElem op)-                                        $ XLam (opWorkerParamIndex op) -                                               (opWorkerBody op))-                                        (XVar uInput))-                                (XVar (UIx 0))--        -- Insert statements that update the accumulator-        --  into the loop body.-        Just nest3      = insertBody nest2 context-                        $ [ BodyAccRead  nAcc tAcc (opWorkerParamAcc op)-                          , BodyAccWrite nAcc tAcc xBody ]-                                -        -- Insert statements that read back the final value-        --  after the loop has finished.-        Just nest4      = insertEnds nest3 context-                        $ [ EndAcc   nResult tAcc nAcc ]-   in   (env1, nest4)--- -- Pack ----------------------------------------- | OpPack{}     <- op- = let  -        -- Lookup binder for the input element.-        Just nSeries    = takeNameOfBound (opInputSeries op)-        tRate           = opInputRate op-        tInputElem      = opElemType op-        (uInput, env1, nest1)-                        = bindNextElem nSeries tRate tInputElem env nest0--        -- Associate the variable for the result element with the result-        -- series. We could instead add an explicit binding, but it's -        -- easier just to insert an entry into the series environment.-        Just nResultSeries = takeNameOfBind (opResultSeries op)-        env2               = insertElemForSeries nResultSeries uInput env1--   in   (env2, nest1)+        ( scheduleScalar - | otherwise- = error $ renderIndent - $ vcat [ text "ddc-core-flow.scheduleOperator"-        , indent 4 $ text "Can't schedule operator."-        , indent 4 $ ppr op ]+         -- * Scheduling process kernels+        , scheduleKernel+        , Error         (..)+        , Lifting       (..))+where+import DDC.Core.Flow.Transform.Schedule.Kernel+import DDC.Core.Flow.Transform.Schedule.Scalar
+ DDC/Core/Flow/Transform/Schedule/Base.hs view
@@ -0,0 +1,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)+
+ DDC/Core/Flow/Transform/Schedule/Error.hs view
@@ -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 ]+
+ DDC/Core/Flow/Transform/Schedule/Kernel.hs view
@@ -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)+
+ DDC/Core/Flow/Transform/Schedule/Lifting.hs view
@@ -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+
DDC/Core/Flow/Transform/Schedule/Nest.hs view
@@ -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
+ DDC/Core/Flow/Transform/Schedule/Scalar.hs view
@@ -0,0 +1,330 @@++module DDC.Core.Flow.Transform.Schedule.Scalar+        (scheduleScalar)+where+import DDC.Core.Flow.Transform.Schedule.Nest+import DDC.Core.Flow.Transform.Schedule.Error+import DDC.Core.Flow.Transform.Schedule.Base+import DDC.Core.Flow.Procedure+import DDC.Core.Flow.Process+import DDC.Core.Flow.Compounds+import DDC.Core.Flow.Prim+import DDC.Core.Flow.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) ]+
− DDC/Core/Flow/Transform/Schedule/SeriesEnv.hs 
@@ -1,157 +0,0 @@--module DDC.Core.Flow.Transform.Schedule.SeriesEnv-        ( SeriesEnv (..)-        , emptySeriesEnv-        , insertElemForSeries--        , bindNextElem-        , bindNextElems-        -        , elemBindOfSeriesBind-        , elemBoundOfSeriesBound-        , elemTypeOfSeriesType-        , rateTypeOfSeriesType )-where-import DDC.Core.Flow.Transform.Schedule.Nest-import DDC.Core.Flow.Procedure-import DDC.Core.Flow.Compounds-import DDC.Core.Flow.Prim-import DDC.Core.Flow.Exp-import qualified Data.Map       as Map-import Data.Map                 (Map)---data SeriesEnv-        = SeriesEnv-        { -- | Maps the bound for a whole series to the bound for-          --   a single element in the series context. -          envSeriesElems        :: Map Name (Bound Name) -        }----- | An empty series environment.-emptySeriesEnv :: SeriesEnv-emptySeriesEnv-        = SeriesEnv Map.empty----- | Insert an entry into the series environment.-insertElemForSeries-        :: Name -> BoundF -> SeriesEnv -> SeriesEnv--insertElemForSeries n u (SeriesEnv env)-        = SeriesEnv (Map.insert n u env)----- | Produce the `Bound` that holds the next element for the given series,---   which exists in the series's context.------   We first try to look up the required bound from the series environment,---   if it's not already available then insert a statement into the loop nest---   to get actually get the next element from the series.-bindNextElem -        :: Name                 -- ^ Name of series.-        -> TypeF                -- ^ Rate of series-        -> TypeF                -- ^ Series element type.-        -> SeriesEnv            -- ^ Current series environment.-        -> Nest                 -- ^ Current loop nest.-        -> (BoundF, SeriesEnv, Nest)--bindNextElem nSeries tRate tElem env nest0-        -- There is already a mapping in the environment.-        | Just uElem    <- Map.lookup nSeries (envSeriesElems env)-        = (uElem, env, nest0)-        -        -- Insert a statement into the loop nest to get the next element-        -- from the series.-        | otherwise-        = let   -- bound for the single element-                nElem   = NameVarMod nSeries "elem"-                uElem   = UName nElem--                -- Expression to get the next element from the series.-                uSeries = UName nSeries-                uIndex  = UIx 0-                xGet    = xNext tRate tElem (XVar uSeries) (XVar uIndex)--                -- Insert the statement into the loop nest.-                Just nest1   -                        = (insertBody nest0 (ContextRate tRate)-                                [ BodyStmt (BName nElem tElem) xGet ])-                                           -                env'    = env { envSeriesElems -                                        = Map.insert nSeries uElem -                                                    (envSeriesElems env) }-           -           in   (uElem, env', nest1)----- | Like `bindNextElem`, but handle several series at once.-bindNextElems -        :: [(Name, TypeF, TypeF)] -                                -- ^ Names, rates, and element types.-        -> SeriesEnv            -- ^ Current series environment.-        -> Nest                 -- ^ Current loop nest.-        -> ([BoundF], SeriesEnv, Nest)--bindNextElems junk env nest0- = case junk of-        []      -         -> ([], env, nest0)-        -        (nSeries, tRate, tElem) : junk'-         -> let (uElem1,  env1, nest1)  -                        = bindNextElem  nSeries tRate tElem env nest0-                -                (uElems', env', nest')-                        = bindNextElems junk' env1 nest1-            -            in  (uElem1 : uElems', env', nest')----- | Given the bind of a series,  produce the bound that refers to the---   next element of the series in its context.-elemBindOfSeriesBind   :: BindF  -> Maybe BindF-elemBindOfSeriesBind bSeries-        | BName nSeries tSeries' <- bSeries-        , nElem         <- NameVarMod nSeries "elem"-        , Just tElem    <- elemTypeOfSeriesType tSeries'-        = Just $ BName nElem tElem--        | otherwise-        = Nothing- ---- | Given the bound of a series, produce the bound that refers to the---   next element of the series in its context.-elemBoundOfSeriesBound :: BoundF -> Maybe BoundF-elemBoundOfSeriesBound uSeries-        | UName nSeries <- uSeries-        , nElem         <- NameVarMod nSeries "elem"-        = Just $ UName nElem--        | otherwise-        = Nothing----- | Given the type of a series like @Series k e@, produce the type---   of a single element, namely the @e@.-elemTypeOfSeriesType :: TypeF -> Maybe TypeF-elemTypeOfSeriesType tSeries'-        | Just (_tcSeries, [_tK, tE]) <- takeTyConApps tSeries'-        = Just tE--        | otherwise-        = Nothing----- | Given the type of a series like @Series k e@, produce the type---   of the rate, namely the @k@.-rateTypeOfSeriesType :: TypeF -> Maybe TypeF-rateTypeOfSeriesType tSeries'-        | Just (_tcSeries, [tK, _tE]) <- takeTyConApps tSeries'-        = Just tK--        | otherwise-        = Nothing-
DDC/Core/Flow/Transform/Slurp.hs view
@@ -1,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)
− DDC/Core/Flow/Transform/Slurp/Alloc.hs 
@@ -1,41 +0,0 @@--module DDC.Core.Flow.Transform.Slurp.Alloc-        (patchAllocRates)-where-import DDC.Core.Flow.Process.Operator----- | Decide what rates should be used to allocate created vectors.---   When a vector is being created in a selector context then we need to ---   use the maximum possible length, which is the outer context instead---   of the inner one created by the selector.-patchAllocRates :: [Operator] -> [Operator]-patchAllocRates ops- = let-        -- Build a table of output to input rates for all pack operations.-        packRates       -         = [ (opOutputRate op, opInputRate op)-                | op@OpPack{}   <- ops ]--        -- Fix the number of nested contexts to some finite number so we-        -- don't end up diverging if there is a loop in the  list of-        -- operator descriptions.-        maxNestedContexts = 1000 :: Int--        getAllocRate 0 _rate-         = error $ unlines-                 [ "ddc-core-flow.patchAllocRates"-                 , "    Too many nested contexts." ]--        getAllocRate n rate-         = case lookup rate packRates of-                Just inRate     -> getAllocRate (n - 1) inRate-                _               -> rate--        patchOperator op@OpCreate{}-         = op { opAllocRate = Just $ getAllocRate maxNestedContexts (opInputRate op) }--        patchOperator op-         = op--   in   map patchOperator ops
+ DDC/Core/Flow/Transform/Slurp/Context.hs view
@@ -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++
+ DDC/Core/Flow/Transform/Slurp/Error.hs view
@@ -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]+
DDC/Core/Flow/Transform/Slurp/Operator.hs view
@@ -1,13 +1,15 @@  module DDC.Core.Flow.Transform.Slurp.Operator-        (slurpOperator)+        ( slurpOperator+        , isSeriesOperator+        , isVectorOperator) where import DDC.Core.Flow.Process.Operator import DDC.Core.Flow.Exp import DDC.Core.Flow.Prim-import DDC.Core.Flow.Prim.TyConPrim-import DDC.Core.Compounds.Simple-import DDC.Type.Pretty          ()+import DDC.Core.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
+ DDC/Core/Flow/Transform/Slurp/Resize.hs view
@@ -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)+
DDC/Core/Flow/Transform/Thread.hs view
@@ -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
+ DDC/Core/Flow/Transform/TransformUpX.hs view
@@ -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+
DDC/Core/Flow/Transform/Wind.hs view
@@ -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.
LICENSE view
@@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyrite (K) 2007-2013 The Disciplined Disciple Compiler Strike Force+Copyrite (K) 2007-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-
ddc-core-flow.cabal view
@@ -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