ddc-core-flow 0.4.1.3 → 0.4.2.1

raw patch · 59 files changed

+5444/−1850 lines, 59 filesdep +ddc-core-tetradep +limpdep +limp-cbcdep ~basedep ~ddc-basedep ~ddc-corePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: ddc-core-tetra, limp, limp-cbc

Dependency ranges changed: base, ddc-base, ddc-core, ddc-core-salt, ddc-core-simpl, deepseq, mtl

API changes (from Hackage documentation)

Files

• DDC/Core/Flow/Compounds.hs +10/−3
• DDC/Core/Flow/Context.hs +4/−26
• DDC/Core/Flow/Context/Base.hs +44/−0
• DDC/Core/Flow/Context/FillPath.hs +148/−0
• DDC/Core/Flow/Convert.hs +187/−0
• DDC/Core/Flow/Convert/Base.hs +89/−0
• DDC/Core/Flow/Convert/Exp.hs +463/−0
• DDC/Core/Flow/Convert/Type.hs +206/−0
• DDC/Core/Flow/Env.hs +1/−1
• DDC/Core/Flow/Exp.hs +2/−2
• DDC/Core/Flow/Lower.hs +97/−30
• DDC/Core/Flow/Prim.hs +28/−10
• DDC/Core/Flow/Prim/Base.hs +73/−3
• DDC/Core/Flow/Prim/DaConFlow.hs +5/−3
• DDC/Core/Flow/Prim/DaConPrim.hs +2/−2
• DDC/Core/Flow/Prim/KiConFlow.hs +10/−4
• DDC/Core/Flow/Prim/OpConcrete.hs +36/−33
• DDC/Core/Flow/Prim/OpControl.hs +14/−15
• DDC/Core/Flow/Prim/OpPrim.hs +8/−7
• DDC/Core/Flow/Prim/OpSeries.hs +297/−87
• DDC/Core/Flow/Prim/OpStore.hs +37/−8
• DDC/Core/Flow/Prim/OpVector.hs +14/−3
• DDC/Core/Flow/Prim/TyConFlow.hs +91/−25
• DDC/Core/Flow/Prim/TyConPrim.hs +5/−4
• DDC/Core/Flow/Procedure.hs +3/−6
• DDC/Core/Flow/Process.hs +0/−1
• DDC/Core/Flow/Process/Operator.hs +83/−2
• DDC/Core/Flow/Process/Pretty.hs +58/−3
• DDC/Core/Flow/Process/Process.hs +11/−26
• DDC/Core/Flow/Profile.hs +7/−3
• DDC/Core/Flow/Transform/Concretize.hs +21/−21
• DDC/Core/Flow/Transform/Extract.hs +31/−25
• DDC/Core/Flow/Transform/Forward.hs +68/−0
• DDC/Core/Flow/Transform/Melt.hs +6/−4
• DDC/Core/Flow/Transform/Rates/Clusters.hs +17/−0
• DDC/Core/Flow/Transform/Rates/Clusters/Base.hs +37/−0
• DDC/Core/Flow/Transform/Rates/Clusters/Greedy.hs +126/−0
• DDC/Core/Flow/Transform/Rates/Clusters/Linear.hs +320/−0
• DDC/Core/Flow/Transform/Rates/CnfFromExp.hs +205/−0
• DDC/Core/Flow/Transform/Rates/Combinators.hs +304/−0
• DDC/Core/Flow/Transform/Rates/Constraints.hs +0/−351
• DDC/Core/Flow/Transform/Rates/Fail.hs +12/−3
• DDC/Core/Flow/Transform/Rates/Graph.hs +141/−82
• DDC/Core/Flow/Transform/Rates/SeriesOfVector.hs +405/−355
• DDC/Core/Flow/Transform/Rates/SizeInference.hs +484/−0
• DDC/Core/Flow/Transform/Schedule/Base.hs +42/−20
• DDC/Core/Flow/Transform/Schedule/Error.hs +6/−7
• DDC/Core/Flow/Transform/Schedule/Kernel.hs +93/−103
• DDC/Core/Flow/Transform/Schedule/Lifting.hs +3/−2
• DDC/Core/Flow/Transform/Schedule/Nest.hs +140/−210
• DDC/Core/Flow/Transform/Schedule/Scalar.hs +142/−142
• DDC/Core/Flow/Transform/Slurp.hs +224/−107
• DDC/Core/Flow/Transform/Slurp/Context.hs +287/−0
• DDC/Core/Flow/Transform/Slurp/Error.hs +42/−1
• DDC/Core/Flow/Transform/Slurp/Operator.hs +69/−33
• DDC/Core/Flow/Transform/Slurp/Resize.hs +120/−0
• DDC/Core/Flow/Transform/Thread.hs +14/−14
• DDC/Core/Flow/Transform/Wind.hs +22/−53
• ddc-core-flow.cabal +30/−10

@@ -1,22 +1,27 @@  -- | Short-hands for constructing compound expressions. module DDC.Core.Flow.Compounds-        ( module DDC.Core.Compounds.Simple+        ( module DDC.Core.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, tFloat, tVec@@ -41,6 +46,7 @@         , xNext, xNextC         , xDown         , xTail+        , xSeriesOfRateVec            -- * Control operators         , xLoopN@@ -62,6 +68,7 @@ import DDC.Core.Flow.Prim.DaConPrim 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.Flow.Prim.OpPrim-import DDC.Core.Compounds.Simple+import DDC.Core.Exp.Simple.Compounds

@@ -1,29 +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 mkSel1# function.-        | ContextSelect-        { contextOuterRate      :: Type  Name-        , contextInnerRate      :: Type  Name-        , contextFlags          :: Bound Name-        , contextSelector       :: Bind  Name }---        -- | A nested context created by a mkSegd# function.-        | ContextSegment-        { contextOuterRate      :: Type  Name-        , contextInnerRate      :: Type  Name-        , contextLens           :: Bound Name-        , contextSegd           :: Bind  Name }-        deriving (Show, Eq)-+import DDC.Core.Flow.Context.Base+import DDC.Core.Flow.Context.FillPath

@@ -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++

@@ -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@.+--   +

@@ -0,0 +1,187 @@++-- | 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.Monad.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  = []+                , moduleDataDefsLocal   = []++                , 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)                +        -> ConvertM (T.Name, ExportSource T.Name)++convertExportM (n, esrc)+ = do   n'      <- convertName n+        esrc'   <- convertExportSourceM esrc+        return  (n', esrc')+++-- Convert an export source.+convertExportSourceM +        :: ExportSource F.Name+        -> ConvertM (ExportSource 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)+        -> ConvertM (T.Name, ImportType 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)+        -> ConvertM (T.Name, ImportValue 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+        -> ConvertM (ImportType 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+        -> ConvertM (ImportValue 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'+

@@ -0,0 +1,89 @@++module DDC.Core.Flow.Convert.Base+        (  ConvertM+        ,  Error (..)+        ,  withRateXLAM, isRateXLAM+        ,  withSuspFns,   isSuspFn)+where+import DDC.Base.Pretty+import DDC.Core.Exp.Annot.Compounds+import DDC.Type.Exp+import DDC.Core.Flow.Prim                       as F+import qualified DDC.Control.Monad.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."]+

@@ -0,0 +1,463 @@++-- | 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 -> ConvertM (DaCon 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 ]+

@@ -0,0 +1,206 @@++-- | 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.Monad.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++    TForall b t+     -> TForall <$> convertBind  b <*> convertType t++    TApp p q+     -> TApp    <$> convertType  p <*> convertType q++    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"+

@@ -111,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

@@ -1,6 +1,6 @@  module DDC.Core.Flow.Exp-        ( module DDC.Core.Exp.Simple +        ( module DDC.Core.Exp.Simple.Exp         , KindEnvF, TypeEnvF         , TypeF         , ModuleF@@ -15,7 +15,7 @@ where import DDC.Core.Module import DDC.Core.Flow.Prim-import DDC.Core.Exp.Simple+import DDC.Core.Exp.Simple.Exp import DDC.Type.Env             (Env)  type KindEnvF   = Env Name

@@ -21,7 +21,9 @@ import DDC.Core.Flow.Exp import DDC.Core.Module +import DDC.Core.Transform.TransformUpX import DDC.Core.Transform.Annotate+import DDC.Core.Transform.Deannotate  import qualified DDC.Core.Simplifier                    as C import qualified DDC.Core.Simplifier.Recipe             as C@@ -82,8 +84,8 @@   -- Lower ------------------------------------------------------------------------- | Take a module that contains only well formed series processes defined---   at top-level, and lower them all into procedures. +-- | 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@@ -95,8 +97,14 @@     -- 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 (lowerProcess config) procs+        lets            <- mapM (lowerEither config procnames) procs          -- Wrap all the procedures into a new module.         let mm_lowered  = mm@@ -108,6 +116,59 @@         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+      TForall bind tt' -> TForall bind (replaceProcTy tt')+      TApp l r+       | Just (NameTyConFlow TyConFlowProcess, [_,_]) <- takePrimTyConApps tt+       -> tUnit+       | otherwise+       -> TApp (replaceProcTy l) (replaceProcTy r)+      TSum ts+       -> TSum ts+ + -- | Lower a single series process into fused code. lowerProcess :: Config -> Process -> Either Error (BindF, ExpF) lowerProcess config process@@ -116,10 +177,10 @@  | MethodScalar         <- configMethod config  = do           -- Schedule process into scalar code.-        let Right proc              = scheduleScalar process+        proc                 <- scheduleScalar process          -- Extract code for the kernel-        let (bProc, xProc)          = extractProcedure proc+        let (bProc, xProc)    = extractProcedure proc          return (bProc, xProc) @@ -130,18 +191,18 @@  --  the rate variable (k), as well as a (RateNat k) witness.  --  | MethodVector lifting <- configMethod config- , [nRN]  <- [ nRN | BName nRN tRN <- processParamValues process+ , [nRN]  <- [ nRN | (flag, BName nRN tRN) <- processParamFlags process+                   , not flag                    , isRateNatType tRN ]- , bK : _ <- processParamTypes process+ , tK <- processLoopRate process  = do   let c           = liftingFactor lifting -        -- Get the primary rate variable.-        let Just uK     = takeSubstBoundOfBind bK-        let tK          = TVar uK-         -- The RateNat witness         let xRN         = XVar (UName nRN) +        let tProc       = processProcType process+        let _tLoopRate   = processLoopRate process+         -----------------------------------------         -- Create the vector version of the kernel.         --  Vector code processes several elements per loop iteration.@@ -152,9 +213,10 @@         let bxsDownSeries                        = [ ( bS                     , ( BName (NameVarMod n "down")-                              (tSeries (tDown c tK) tE)-                      , xDown c tK tE (XVar (UIx 0)) xS))-                  | bS@(BName n tS)  <- processParamValues process+                              (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@@ -170,16 +232,19 @@          let Just xsVecValArgs                     = sequence -                $ map getDownValArg (processParamValues process)+                $ map getDownValArg +                $ map snd+                $ filter (not.fst)+                $ processParamFlags process          let bRateDown-                = BAnon (tRateNat (tDown c (TVar uK)))+                = BAnon (tRateNat (tDown c tK))          let xProcVec'                        = XLam bRateDown                 $ xLets [LLet b x | (_, (b, x)) <- bxsDownSeries]-                $ xApps (XApp xProcVec (XType (TVar uK)))-                $ xsVecValArgs+                $ xApps xProcVec+                $ [XType tProc, XType tK] ++ xsVecValArgs           -----------------------------------------@@ -190,9 +255,10 @@          -- Window the input series to select the tails.         let bxsTailSeries-                = [ ( bS, ( BName (NameVarMod n "tail") (tSeries (tTail c tK) tE)-                          , xTail c tK tE (XVar (UIx 0)) xS))-                  | bS@(BName n tS)    <- processParamValues process+                = [ ( 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@@ -202,7 +268,8 @@         let bxsTailVector                 = [ ( bV, ( BName (NameVarMod n "tail") (tVector tE)                           , xTailVector c tK tE (XVar (UIx 0)) xV))-                  | bV@(BName n tV)     <- processParamValues process+                  | (flag, bV@(BName n tV)) <- processParamFlags process+                  , not flag                   , let Just tE = elemTypeOfVectorType tV                   , let Just uV = takeSubstBoundOfBind bV                   , let xV      = XVar uV@@ -221,28 +288,27 @@          let Just xsTailValArgs                 = sequence -                $ map getTailValArg (procedureParamValues procTail)+                $ map getTailValArg (map snd $ filter (not.fst) $ procedureParamFlags procTail)          let bRateTail-                = BAnon (tRateNat (tTail c (TVar uK)))+                = BAnon (tRateNat (tTail c tK))          let xProcTail'                 = XLam bRateTail                 $ xLets [LLet b x | (_, (b, x)) <- bxsTailSeries]                 $ xLets [LLet b x | (_, (b, x)) <- bxsTailVector]-                $ xApps (XApp xProcTail (XType (tTail c (TVar uK))))-                $ xsTailValArgs+                $ xApps xProcTail+                $ [XType tProc, XType (tTail c tK)] ++ xsTailValArgs          ------------------------------------------         -- Stich the vector and scalar versions together.         let xProc-                = foldr XLAM -                       (foldr XLam xBody (processParamValues process))-                       (processParamTypes process)+                = makeXLamFlags (processParamFlags process)+                                xBody              xBody                 = XLet (LLet   (BNone tUnit) -                               (xSplit c (TVar uK) xRN xProcVec' xProcTail'))+                               (xSplit c tK xRN xProcVec' xProcTail'))                        xUnit                          -- Reconstruct a binder for the whole procedure / process.@@ -266,6 +332,7 @@  | otherwise  = error $  "ddc-core-flow.lowerProcess: invalid lowering method"          +  -- Clean ---------------------------------------------------------------------- -- | Do some beta-reductions to ensure that arguments to worker functions

@@ -75,6 +75,8 @@ import DDC.Core.Flow.Prim.OpVector import DDC.Core.Flow.Prim.OpPrim +import DDC.Core.Lexer.Names             (isVarStart)+ import DDC.Core.Salt.Name         ( readPrimTyCon         @@ -86,12 +88,14 @@         , lowerPrimVecToArith                  , readPrimCast-        , readLitPrimNat-        , readLitPrimInt-        , readLitPrimWordOfBits-        , readLitPrimFloatOfBits)+        , readLitNat+        , readLitInt+        , readLitWordOfBits+        , readLitFloatOfBits)          import DDC.Base.Pretty+import DDC.Base.Name+import DDC.Data.ListUtils import Control.DeepSeq import Data.Char         @@ -153,6 +157,16 @@         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@@ -177,32 +191,36 @@         | 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 (val, bits)      <- readLitPrimFloatOfBits str+        | 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.

@@ -94,6 +94,7 @@ -- | Fragment specific kind constructors. data KiConFlow         = KiConFlowRate+        | KiConFlowProc         deriving (Eq, Ord, Show)  @@ -102,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 @@ -123,6 +130,11 @@         -- | @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 @@ -131,6 +143,9 @@          -- | @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)  @@ -173,6 +188,9 @@         -- | 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@@ -180,9 +198,49 @@         -- | Segmented fold.         | OpSeriesFolds -        -- | Convert vector(s) into series, all with same length with runtime check.-        | OpSeriesRunProcess Int+        -- | 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)@@ -265,6 +323,12 @@          -- | Truncate a vector to a smaller length.         | OpStoreTruncVector++        -- | Get a vector's data buffer+        | OpStoreBufOfVector++        -- | Get a vector's data buffer+        | OpStoreBufOfRateVec         deriving (Eq, Ord, Show)  @@ -284,5 +348,11 @@          -- | Get a vector's length.         | OpVectorLength++        -- | Gather  (read) elements from a vector:+        --+        -- > gather v ix = map (v!) ix+        --+        | OpVectorGather         deriving (Eq, Ord, Show) 

@@ -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.Core.Exp.Simple.Exp+import DDC.Core.Exp.Simple.Compounds import DDC.Base.Pretty import Data.List import Data.Char import Control.DeepSeq  -instance NFData DaConFlow+instance NFData DaConFlow where+ rnf !_ = ()+   instance Pretty DaConFlow where  ppr dc

@@ -9,8 +9,8 @@ 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.Exp.Simple.Compounds+import DDC.Core.Exp.Simple.Exp   -- | A literal @Bool#@

@@ -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.Core.Exp.Simple.Exp+import DDC.Type.Compounds import DDC.Base.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)

@@ -11,21 +11,22 @@         , xNextC          , xDown-        , xTail)+        , xTail ) where import DDC.Core.Flow.Prim.KiConFlow import DDC.Core.Flow.Prim.TyConFlow import DDC.Core.Flow.Prim.TyConPrim import DDC.Core.Flow.Prim.Base-import DDC.Core.Compounds.Simple-import DDC.Core.Exp.Simple+import DDC.Core.Exp.Simple.Compounds+import DDC.Core.Exp.Simple.Exp import DDC.Base.Pretty import Control.DeepSeq import Data.List import Data.Char  -instance NFData OpConcrete+instance NFData OpConcrete where+ rnf !_ = ()   instance Pretty OpConcrete where@@ -101,11 +102,11 @@                         (TVar (UIx (a - ix)))  -        -- rateOfSeries#   :: [k : Rate]. [a : Data]-        --                 .  Series k a -> RateNat k+        -- rateOfSeries#   :: [p : Proc]. [k : Rate]. [a : Data]+        --                 .  Series p k a -> RateNat k         OpConcreteRateOfSeries -         -> tForalls [kRate, kData] $ \[tK, tA]-                -> tSeries tK tA `tFun` tRateNat tK+         -> tForalls [kProc, kRate, kData] $ \[tP, tKR, tA]+                -> tSeries tP tKR tA `tFun` tRateNat tKR          -- natOfRateNat#   :: [k : Rate]. RateNat k -> Nat#         OpConcreteNatOfRateNat @@ -114,30 +115,31 @@          -- next#   :: [a : Data]. [k : Rate]. Series# k a -> Nat# -> a         OpConcreteNext 1-         -> tForalls [kData, kRate]-         $  \[tA, tK] -> tSeries tK tA `tFun` tNat `tFun` tA+         -> 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, kRate]-         $  \[tA, tK] -> tSeries (tDown n tK) tA `tFun` tNat `tFun` tVec n tA+         -> 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 [kRate, kData]-         $  \[tK, tA] -> tRateNat (tDown n tK) -                        `tFun` tSeries tK tA `tFun` tSeries (tDown n tK) tA+         -> 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 [kRate, kData]-         $  \[tK, tA] -> tRateNat (tTail n tK)-                        `tFun` tSeries tK tA `tFun` tSeries (tTail n tK) tA+         -> 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@@ -148,10 +150,10 @@                   ([XType t | t <- ts] ++ [x])  -xRateOfSeries :: TypeF -> TypeF -> ExpF -> ExpF-xRateOfSeries tK tA xS +xRateOfSeries :: TypeF -> TypeF -> TypeF -> ExpF -> ExpF+xRateOfSeries tP tK tA xS           = xApps  (xVarOpConcrete OpConcreteRateOfSeries) -                  [XType tK, XType tA, xS]+                  [XType tP, XType tK, XType tA, xS]   xNatOfRateNat :: TypeF -> ExpF -> ExpF@@ -160,28 +162,29 @@                  [XType tK, xR]  -xNext  :: TypeF -> TypeF -> ExpF -> ExpF -> ExpF-xNext tRate tElem xStream xIndex+xNext  :: TypeF -> TypeF -> TypeF -> ExpF -> ExpF -> ExpF+xNext tProc tRate tElem xStream xIndex  = xApps (xVarOpConcrete (OpConcreteNext 1))-         [XType tElem, XType tRate, xStream, xIndex]+         [XType tElem, XType tProc, XType tRate, xStream, xIndex]  -xNextC :: Int -> TypeF -> TypeF -> ExpF -> ExpF -> ExpF-xNextC c tRate tElem xStream xIndex+xNextC :: Int -> TypeF -> TypeF -> TypeF -> ExpF -> ExpF -> ExpF+xNextC c tProc tRate tElem xStream xIndex  = xApps (xVarOpConcrete (OpConcreteNext c))-         [XType tElem, XType tRate, xStream, xIndex]+         [XType tElem, XType tProc, XType tRate, xStream, xIndex]  -xDown  :: Int -> TypeF -> TypeF -> ExpF -> ExpF -> ExpF-xDown n tR tE xRN xS+xDown  :: Int -> TypeF -> TypeF -> TypeF -> ExpF -> ExpF -> ExpF+xDown n tP tK tE xRN xS  = xApps (xVarOpConcrete (OpConcreteDown n))-         [XType tR, XType tE, xRN, xS]+         [XType tP, XType tK, XType tE, xRN, xS]  -xTail  :: Int -> TypeF -> TypeF -> ExpF -> ExpF -> ExpF-xTail n tR tE xRN xS+xTail  :: Int -> TypeF -> TypeF -> TypeF -> ExpF -> ExpF -> ExpF+xTail n tP tK tE xRN xS  = xApps (xVarOpConcrete (OpConcreteTail n))-         [XType tR, XType tE, xRN, xS]+         [XType tP, XType tK, XType tE, xRN, xS]+   -- Utils -----------------------------------------------------------------------

@@ -12,15 +12,16 @@ 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.Core.Exp.Simple.Compounds+import DDC.Core.Exp.Simple.Exp import DDC.Base.Pretty import Control.DeepSeq import Data.Char import Data.List  -instance NFData OpControl+instance NFData OpControl where+ rnf !_ = ()   instance Pretty OpControl where@@ -68,9 +69,8 @@          -- guard#   :: Ref# Nat# -> Bool# -> (Nat# -> Unit) -> Unit         OpControlGuard -         -> tRef tNat-                `tFun` tBool-                `tFun` (tNat `tFun` tUnit)+         ->            tBool+                `tFun` (tUnit `tFun` tUnit)                 `tFun` tUnit          -- segment# :: Ref Nat# -> Nat#  -> (Nat# -> Nat# -> Unit) -> Unit@@ -78,9 +78,8 @@         --   element in the segment, and the second is the index into the          --   overall series.         OpControlSegment-         -> tRef tNat-                `tFun` tNat-                `tFun` (tNat `tFun` tNat `tFun` tUnit)+         ->            tNat+                `tFun` (tNat `tFun` tUnit)                 `tFun` tUnit          -- split#  :: [k : Rate]. RateNat# k@@ -106,16 +105,16 @@                 [XType tR, xRN, xF]  -xGuard   :: ExpF -> ExpF -> ExpF -> ExpF-xGuard xCount xFlag xFun+xGuard   :: ExpF -> ExpF -> ExpF+xGuard xFlag xFun         = xApps (xVarOpControl OpControlGuard) -                [xCount, xFlag, xFun]+                [xFlag, xFun]  -xSegment :: ExpF -> ExpF -> ExpF -> ExpF-xSegment xCount xIters xFun+xSegment :: ExpF -> ExpF -> ExpF+xSegment xIters xFun         = xApps (xVarOpControl OpControlSegment)-                [xCount, xIters, xFun]+                [xIters, xFun]   xSplit  :: Int  -> TypeF -> ExpF

@@ -12,9 +12,10 @@ 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.Exp.Simple.Compounds+import DDC.Core.Exp.Simple.Exp   -- | Take the type of a primitive cast.@@ -87,8 +88,8 @@          $  \t -> tVec n t `tFun` t          PrimVecGather n-         -> tForall kData-         $  \t -> tVector t `tFun` tVec n tNat `tFun` tVec n t+         -> tForalls [kRate, kData]+         $  \[k, t] -> tRateVec k t `tFun` tVec n tNat `tFun` tVec n t          PrimVecScatter n          -> tForall kData@@ -106,10 +107,10 @@  = xApps (xVarPrimVec (PrimVecProj n i))          [XType tA, xV] -xvGather  :: Int -> Type Name -> Exp () Name -> Exp () Name -> Exp () Name-xvGather c tA xVec xIxs+xvGather  :: Int -> Type Name -> Type Name -> Exp () Name -> Exp () Name -> Exp () Name+xvGather c tK tA xVec xIxs  = xApps (xVarPrimVec (PrimVecGather c))-         [XType tA, xVec, xIxs]+         [XType tK, XType tA, xVec, xIxs]   xvScatter :: Int -> Type Name -> Exp () Name -> Exp () Name -> Exp () Name -> Exp () Name

@@ -1,22 +1,26 @@  module DDC.Core.Flow.Prim.OpSeries         ( readOpSeries-        , typeOpSeries)+        , 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.Transform.LiftT-import DDC.Core.Compounds.Simple-import DDC.Core.Exp.Simple+import DDC.Core.Transform.BoundT+import DDC.Core.Exp.Simple.Compounds+import DDC.Core.Exp.Simple.Exp import DDC.Base.Pretty import Control.DeepSeq import Data.List import Data.Char          -instance NFData OpSeries+instance NFData OpSeries where+ rnf !_ = ()   instance Pretty OpSeries where@@ -42,15 +46,32 @@          OpSeriesPack            -> text "spack"                 <> text "#" +        OpSeriesGenerate        -> text "sgenerate"             <> text "#"+         OpSeriesReduce          -> text "sreduce"               <> text "#"         OpSeriesFolds           -> text "sfolds"                <> text "#"          OpSeriesJoin            -> text "pjoin"                 <> text "#" -        OpSeriesRunProcess 1    -> text "runProcess"            <> text "#"-        OpSeriesRunProcess n    -> text "runProcess" <> int n   <> text "#"+        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@@ -67,11 +88,11 @@         , arity == 1         = Just $ OpSeriesMkSel arity -        | Just rest     <- stripPrefix "runProcess" str+        | Just rest     <- stripPrefix "ratify" str         , (ds, "#")     <- span isDigit rest         , not $ null ds         , arity         <- read ds-        = Just $ OpSeriesRunProcess arity+        = Just $ OpSeriesRateVecsOfVectors arity           | otherwise@@ -84,12 +105,27 @@                 "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 1+                "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  @@ -108,38 +144,38 @@ takeTypeOpSeries op  = case op of         -- Replicates --------------------------        -- rep  :: [k : Rate] [a : Data] -        --      .  a -> Series k a+        -- rep  :: [p : Proc] [k : Rate] [a : Data] +        --      .  a -> Series p k a         OpSeriesRep -         -> Just $ tForalls [kRate, kData] $ \[tR, tA]-                -> tA `tFun` tSeries tR tA+         -> Just $ tForalls [kProc, kRate, kData] $ \[tP, tR, tA]+                -> tA `tFun` tSeries tP tR tA -        -- reps  :: [k1 k2 : Rate]. [a : Data]-        --       .  Segd k1 k2 -> Series k1 a -> Series k2 a+        -- reps  :: [p : Proc]. [k1 k2 : Rate]. [a : Data]+        --       .  Segd k1 k2 -> Series p k1 a -> Series p k2 a         OpSeriesReps -         -> Just $ tForalls [kRate, kRate, kData] $ \[tK1, tK2, tA]-                -> tSegd tK1 tK2 `tFun` tSeries tK1 tA `tFun` tSeries tK2 tA+         -> 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 :: [k1 k2 : Rate]. -        --         .  Segd k1 k2 -> Series k2 Nat+        -- indices :: [p : Proc]. [k1 k2 : Rate]. +        --         .  Segd k1 k2 -> Series p k2 k1 Nat         OpSeriesIndices-         -> Just $ tForalls [kRate, kRate] $ \[tK1, tK2]-                 -> tSegd tK1 tK2 `tFun` tSeries tK2 tNat+         -> Just $ tForalls [kProc, kRate, kRate] $ \[tP, tK1, tK2]+                 -> tSegd tK1 tK2 `tFun` tSeries tP tK2 tNat           -- Maps ----------------------------------        -- map   :: [k : Rate] [a b : Data]-        --       .  (a -> b) -> Series k a -> Series k b+        -- 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 [kRate, kData, kData] $ \[tK, tA, tB]+         -> Just $ tForalls [kProc, kRate, kData, kData] $ \[tP, tKR, tA, tB]                 ->       (tA `tFun` tB)-                `tFun` tSeries tK tA-                `tFun` tSeries tK tB+                `tFun` tSeries tP tKR tA+                `tFun` tSeries tP tKR tB -        -- mapN  :: [k : Rate] [a0..aN : Data]-        --       .  (a0 -> .. aN) -> Series k a0 -> .. Series k aN+        -- 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   @@ -147,115 +183,289 @@                                 | i <- reverse [0..n] ]           , Just tBody <- tFunOfList-                         (tWork : [tSeries (TVar (UIx (n + 1))) (TVar (UIx i)) +                         (tWork : [tSeries (TVar $ UIx $ n + 2) (TVar $ UIx $ n + 1)+                                           (TVar $ UIx   i)                                  | i <- reverse [0..n] ])           -> Just $ foldr TForall tBody-                         [ BAnon k | k <- kRate : replicate (n + 1) kData ]+                         [ BAnon k | k <- kProc : kRate : replicate (n + 1) kData ]           -- Packs ---------------------------------        -- pack  :: [k1 k2 : Rate]. [a : Data]+        -- pack  :: [p : Proc]. [k1 k2 kL : Rate]. [a : Data]         --       .  Sel2 k1 k2-        --       -> Series k1 a -> Series k2 a+        --       -> Series p k1 kL a -> Series p k2 kL a         OpSeriesPack-         -> Just $ tForalls [kRate, kRate, kData] $ \[tK1, tK2, tA]-                ->     tSel1   tK1 tK2 -                `tFun` tSeries tK1 tA `tFun` tSeries tK2 tA+         -> 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#    :: Process -> Process -> Process+        -- join#    :: [p : Proc]. [k : Rate]. [a b : Data].+        --          .  Process p k a+        --          -> Process p k b+        --          -> Process p k (a,b)         OpSeriesJoin-         -> Just $ tProcess `tFun` tProcess `tFun` tProcess+         -> Just $ tForalls [kProc, kRate] $+                \[tP, tK]+                ->     tProcess tP tK+                `tFun` tProcess tP tK+                `tFun` tProcess tP tK  -        -- mkSel1#  :: [k1 : Rate].-        --          .  Series k1 Bool#-        --          -> ([k2 : Rate]. Sel1 k1 k2 -> Process#)-        --          -> Process#+        -- 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 [kRate] $ \[tK1]-                ->       tSeries tK1 tBool+         -> Just $ tForalls [kProc, kRate, kRate] $ \[tP, tK1, tKL]+                ->       tSeries tP tK1 tBool                 `tFun` (tForall kRate $ \tK2 -                                -> tSel1 (liftT 1 tK1) tK2 `tFun` tProcess)-                `tFun` tProcess+                                -> tSel1 (liftT 1 tP) (liftT 1 tK1) tK2 `tFun` tProcess (liftT 1 tP) (liftT 1 tKL))+                `tFun` tProcess tP tKL  -        -- mkSegd#  :: [k1 : Rate]-        --          .  Series# k1 Nat#-        --          -> ([k2 : Rate]. Segd# k1 k2 -> Process#)-        --          -> Process#+        -- 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 [kRate] $ \[tK1]-                ->      tSeries tK1 tNat+         -> Just $ tForalls [kProc, kRate] $ \[tP, tK1]+                ->      tSeries tP tK1 tNat                 `tFun` (tForall kRate $ \tK2-                                -> tSegd (liftT 1 tK1) tK2 `tFun` tProcess)-                `tFun` tProcess+                                -> tSegd (liftT 1 tK1) tK2 `tFun` tProcess (liftT 1 tP) (liftT 1 tK1))+                `tFun` tProcess tP tK1  -        -- runProcessN# :: [a0..aN : Data]+        -- 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]. RateNat k -> Series k a0 .. Series k aN -> Process)-        --          -> Bool-        OpSeriesRunProcess n+        --          -> ([k : Rate]. RateVec k a0 .. RateVec k aN -> z)+        --          -> z+        OpSeriesRateVecsOfVectors n          | tK         <- TVar (UIx 0)           , Just tWork <- tFunOfList   -                       $ [ tRateNat tK ]-                       ++[ tSeries tK (TVar (UIx i))-                                | i <- reverse [1..n] ]-                       ++[ tProcess ]+                       $ [ 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 [0..n-1] ]-                         ++[ tWork', tBool ]+                         $ [ tVector (TVar (UIx i)) | i <- reverse [1..n] ]+                         ++[ tWork', TVar (UIx 0) ]           -> Just $ foldr TForall tBody-                         [ BAnon k | k <- replicate n kData ]+                         [ 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# :: [k : Rate]. [a : Data]-        --        .  Ref a -> (a -> a -> a) -> a -> Series k a -> Process+        -- reduce# :: [p : Proc]. [k : Rate]. [a : Data]+        --        .  Ref a -> (a -> a -> a) -> a -> Series p k a -> Process p k         OpSeriesReduce-         -> Just $ tForalls [kRate, kData] $ \[tK, tA]+         -> Just $ tForalls [kProc, kRate, kData] $ \[tP, tK, tA]                  ->     tRef tA                  `tFun` (tA `tFun` tA `tFun` tA)                  `tFun` tA-                 `tFun` tSeries tK tA-                 `tFun` tProcess+                 `tFun` tSeries  tP tK tA+                 `tFun` tProcess tP tK  -        -- folds#   :: [k1 k2 : Rate]. [a : Data]-        --          .  Segd# k1 k2 -> Series k1 a -> Series k2 b+        -- folds#   :: [p : Proc]. [k1 k2 : Rate]. [a : Data]+        --          .  Segd# k1 k2 -> Series p k1 a -> Series k2 b         OpSeriesFolds-         -> Just $ tForalls [kRate, kRate, kData] $ \[tK1, tK2, tA]-                 ->     tSegd tK1 tK2 `tFun` tSeries tK1 tA `tFun` tSeries tK2 tA+         -> 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# :: [k : Rate]. [a : Data]-        --          .  Vector a -> Series k Nat# -> Series k a -> Process+        -- scatter# :: [p : Proc]. [k : Rate]. [a : Data]+        --          .  Vector a -> Series p k Nat# -> Series p k a -> Process p k         OpSeriesScatter-         -> Just $ tForalls [kRate, kData] $ \[tK, tA]-                 -> tVector tA -                 `tFun` tSeries tK tNat `tFun` tSeries tK tA `tFun` tProcess+         -> 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#  :: [k : Rate]. [a : Data]-        --          . Vector a -> Series k Nat# -> Series k a+        -- gather#  :: [p : Proc]. [k1 k2 : Rate]. [a : Data]+        --          . RateVec k1 a -> Series p k2 Nat# -> Series p k2 a         OpSeriesGather-         -> Just $ tForalls [kRate, kData] $ \[tK, tA]-                 -> tVector tA -                 `tFun` tSeries tK tNat `tFun` tSeries tK tA+         -> Just $ tForalls [kProc, kRate, kRate, kData] $ \[tP, tK1, tK2, tA]+                 ->     tRateVec   tK1     tA +                 `tFun` tSeries tP tK2 tNat+                 `tFun` tSeries tP tK2 tA  -        -- fill#    :: [k : Rate]. [a : Data]. Vector a -> Series k a -> Process+        -- fill#    :: [p : Proc]. [k : Rate]. [a : Data]. Vector a -> Series p k a -> Process p k         OpSeriesFill-         -> Just $ tForalls [kRate, kData] $ \[tK, tA] -                -> tVector tA `tFun` tSeries tK tA `tFun` tProcess+         -> 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))+

@@ -8,20 +8,22 @@         , xReadVector,  xReadVectorC         , xWriteVector, xWriteVectorC         , xTailVector-        , xTruncVector)+        , 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.Core.Exp.Simple.Compounds+import DDC.Core.Exp.Simple.Exp import DDC.Base.Pretty import Control.DeepSeq import Data.List import Data.Char -instance NFData OpStore+instance NFData OpStore where+ rnf !_ = ()   instance Pretty OpStore where@@ -47,6 +49,8 @@         OpStoreTailVector  n    -> text "vtail"   <> int n <> text "#"          OpStoreTruncVector      -> text "vtrunc#"+        OpStoreBufOfVector      -> text "vbuf#"+        OpStoreBufOfRateVec     -> text "vbufofratevec#"   -- | Read a store operator name.@@ -86,6 +90,8 @@                 "vwrite#"       -> Just (OpStoreWriteVector 1)                 "vtail#"        -> Just (OpStoreTailVector  1)                 "vtrunc#"       -> Just OpStoreTruncVector+                "vbuf#"         -> Just OpStoreBufOfVector+                "vbufofratevec#"-> Just OpStoreBufOfRateVec                  _               -> Nothing @@ -126,22 +132,22 @@         -- 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          -- vreadN#  :: [a : Data]. Vector# a -> Nat# -> VecN# a         OpStoreReadVector n          -> tForall kData -         $  \tA -> tVector tA `tFun` tNat `tFun` tVec n tA+         $  \tA -> tBuffer tA `tFun` tNat `tFun` tVec n tA          -- vwrite# :: [a : Data]. Vector# a -> Nat# -> a -> Unit         OpStoreWriteVector 1          -> tForall kData -         $  \tA -> tVector tA `tFun` tNat `tFun` tA `tFun` tUnit+         $  \tA -> tBuffer tA `tFun` tNat `tFun` tA `tFun` tUnit          -- vwriteN# :: [a : Data]. Vector# a -> Nat# -> VecN# a -> Unit         OpStoreWriteVector n          -> tForall kData -         $  \tA -> tVector tA `tFun` tNat `tFun` tVec n tA `tFun` tUnit+         $  \tA -> tBuffer tA `tFun` tNat `tFun` tVec n tA `tFun` tUnit          -- vtail$N# :: [k : Rate]. [a : Data]. RateNat (TailN k) -> Vector# a -> Vector# a         OpStoreTailVector n@@ -153,7 +159,18 @@          -> 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@@ -225,6 +242,18 @@ 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]++xBufOfRateVec :: Type Name -> Type Name -> Exp () Name -> Exp () Name+xBufOfRateVec tRate tElem xArr+ = xApps (xVarOpStore OpStoreBufOfRateVec)+         [XType tRate, XType tElem, xArr]++   -- Utils ----------------------------------------------------------------------

@@ -6,15 +6,16 @@ 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.Core.Exp.Simple.Compounds+import DDC.Core.Exp.Simple.Exp import DDC.Base.Pretty import Control.DeepSeq import Data.List import Data.Char          -instance NFData OpVector+instance NFData OpVector where+ rnf !_ = ()   instance Pretty OpVector where@@ -30,7 +31,9 @@         OpVectorGenerate          -> text "vgenerate"             <> text "#"         OpVectorLength            -> text "vlength"               <> text "#" +        OpVectorGather            -> text "vgather"               <> text "#" + -- | Read a data flow operator name. readOpVector :: String -> Maybe OpVector readOpVector str@@ -47,6 +50,7 @@                 "vreduce#"      -> Just $ OpVectorReduce                 "vgenerate#"    -> Just $ OpVectorGenerate                 "vlength#"      -> Just $ OpVectorLength+                "vgather#"      -> Just $ OpVectorGather                 _               -> Nothing  @@ -120,6 +124,13 @@         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 

@@ -9,12 +9,17 @@         , isSeriesType         , isRefType         , isVectorType+        , isRateVecType+        , isBufferType+        , isProcessType            -- * Compounds         , tTuple1         , tTuple2         , tTupleN         , tVector+        , tBuffer+        , tRateVec         , tSeries         , tSegd         , tSel1@@ -22,37 +27,46 @@         , tRef         , tWorld         , tRateNat+        , tRateAppend+        , tRateCross         , tDown         , tTail-        , tProcess)+        , 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.Core.Exp.Simple.Compounds+import DDC.Core.Exp.Simple.Exp import DDC.Base.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#"-        TyConFlowDown n         -> text "Down"  <> int n <> text "#"-        TyConFlowTail n         -> text "Tail"  <> int n <> text "#"+        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.@@ -78,14 +92,19 @@          | 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  @@ -95,16 +114,21 @@ 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        -> kData+        TyConFlowProcess        -> kProc `kFun` kRate `kFun` kData+        TyConFlowResize         -> kProc `kFun` kRate `kFun` kRate `kFun` kData   -- Predicates -----------------------------------------------------------------@@ -120,11 +144,11 @@ isSeriesType :: Type Name -> Bool isSeriesType tt  = case takePrimTyConApps tt of-        Just (NameTyConFlow TyConFlowSeries, [_, _]) -> True-        _                                            -> False+        Just (NameTyConFlow TyConFlowSeries, [_, _, _]) -> True+        _                                               -> False  --- | Check is some type is a fully applied type of a Ref.+-- | Check if some type is a fully applied type of a Ref. isRefType :: Type Name -> Bool isRefType tt  = case takePrimTyConApps tt of@@ -132,7 +156,7 @@         _                                            -> False  --- | Check is some type is a fully applied type of a Vector.+-- | Check if some type is a fully applied type of a Vector. isVectorType :: Type Name -> Bool isVectorType tt  = case takePrimTyConApps tt of@@ -140,6 +164,29 @@         _                                            -> 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]@@ -153,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@@ -184,7 +238,14 @@ tRateNat :: Type Name -> Type Name 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 @@ -193,8 +254,13 @@ tTail n tK      = tApp (tConTyConFlow $ TyConFlowTail n) tK  -tProcess :: Type Name -tProcess = tConTyConFlow $ TyConFlowProcess+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 ----------------------------------------------------------------------

@@ -10,8 +10,8 @@         , tVec) where import DDC.Core.Flow.Prim.Base-import DDC.Core.Compounds.Simple-import DDC.Core.Exp.Simple+import DDC.Core.Exp.Simple.Compounds+import DDC.Core.Exp.Simple.Exp   -- | Yield the kind of a type constructor.@@ -19,16 +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+        PrimTyConTextLit -> kData         PrimTyConVec   _ -> kData `kFun` kData-        PrimTyConString  -> kData   -- Compounds ------------------------------------------------------------------

@@ -15,15 +15,13 @@ 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]+        , procedureParamFlags   :: [(Bool,BindF)]         , procedureNest         :: Nest }  -- | A loop nest.@@ -39,8 +37,7 @@         , nestStart             :: [StmtStart]         , nestBody              :: [StmtBody]         , nestInner             :: Nest-        , nestEnd               :: [StmtEnd] -        , nestResult            :: Exp () Name }+        , nestEnd               :: [StmtEnd] }          -- Guarded context,          -- used when lowering pack-like operations.@@ -168,5 +165,5 @@         | EndVecTrunc         { endVecName            :: Name         , endVecType            :: Type Name-        , endVecRate            :: Type Name }+        , endVecAcc             :: Bound Name }         deriving Show

@@ -1,7 +1,6 @@  module DDC.Core.Flow.Process         ( Process       (..)-        , typeOfProcess          , Operator      (..)) where

@@ -1,6 +1,7 @@  module DDC.Core.Flow.Process.Operator-        (Operator (..))+        ( Operator (..)+        , bindOfOp) where import DDC.Core.Flow.Exp @@ -112,6 +113,9 @@           -- Rate of input and output series.         , opInputRate           :: TypeF +          -- Rate of input vector series.+        , opVectorRate          :: TypeF+           -- Type of gathered elements.         , opElemType            :: TypeF          }@@ -182,6 +186,22 @@         , 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 body.+        , opWorkerBody          :: ExpF+        }++        -----------------------------------------         -- | Reduce the elements of a series into a reference.         | OpReduce         { -- Binder for result value (a Unit)@@ -208,5 +228,66 @@           -- Worker body.         , opWorkerBody          :: ExpF         }-        deriving Show +        -----------------------------------------+        -- | Convert a series from a vector+        | OpSeriesOfRateVec+        { -- Binder for result series.+          opResultSeries        :: BindF++          -- Rate of the input series.+        , opInputRate           :: TypeF++          -- Bound of the input vector+        , opInputRateVec        :: BoundF++          -- Type of the elements.+        , opElemType            :: TypeF+        }++        -----------------------------------------+        -- | 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

@@ -2,6 +2,7 @@ module DDC.Core.Flow.Process.Pretty where import DDC.Core.Flow.Process.Process import DDC.Core.Flow.Process.Operator+import DDC.Core.Flow.Context import DDC.Base.Pretty import DDC.Core.Pretty          () @@ -10,10 +11,43 @@  ppr p   = vcat   $     [ ppr (processName 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@@ -70,6 +104,11 @@         , 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"@@ -79,10 +118,26 @@  ppr op@OpMap{}         = vcat         [ text "Map"-        , text " rate:    "     <> ppr (opInputRate     op) ]+        , 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) ]++ 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) ]++

@@ -1,10 +1,7 @@  module DDC.Core.Flow.Process.Process-        ( Process       (..)-        , typeOfProcess)+        ( Process       (..)) where-import DDC.Core.Flow.Process.Operator-import DDC.Core.Flow.Compounds import DDC.Core.Flow.Context import DDC.Core.Flow.Prim import DDC.Core.Flow.Exp@@ -19,32 +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] +        , processContext        :: Context         } ---- | Take the functional type of a process.-typeOfProcess :: Process -> TypeF-typeOfProcess process- = let  tBody   = foldr tFun tProcess-                $ map typeOfBind (processParamValues process)--        tQuant  = foldr TForall tBody-                $ processParamTypes process--   in   tQuant

@@ -28,7 +28,8 @@         , profilePrimKinds              = primKindEnv         , profilePrimTypes              = primTypeEnv         , profileTypeIsUnboxed          = const False -        , profileNameIsHole             = Nothing }+        , profileNameIsHole             = Nothing +        , profileMakeStringName         = Nothing }   features :: Features@@ -39,10 +40,13 @@         , 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@@ -60,7 +64,7 @@  where rn (Token strTok sp)          = case renameTok readName strTok of                 Just t' -> Token t' sp-                Nothing -> Token (KJunk "lexical error") sp+                Nothing -> Token (KErrorJunk "lexical error") sp   -- | Lex a string to tokens, using primitive names.@@ -72,7 +76,7 @@  where rn (Token strTok sp)          = case renameTok readName strTok of                 Just t' -> Token t' sp-                Nothing -> Token (KJunk "lexical error") sp+                Nothing -> Token (KErrorJunk "lexical error") sp   -- | Create a new type variable name that is not in the given environment.

@@ -37,24 +37,24 @@         -- loop# -> loopn#         -- using the length of a series to get the rate.         | Just ( NameOpControl OpControlLoop-               , [XType tK, xF]) <- takeXPrimApps xx-        , Just (nS, _, tA)       <- findSeriesWithRate tenv tK-        , xS                     <- XVar (UName nS)+               , [XType tK, xF])   <- takeXPrimApps xx+        , Just (nS, tP, _, tA)     <- findSeriesWithRate tenv tK+        , xS                       <- XVar (UName nS)         = Just          $ xLoopN                  tK                              -- type level rate-                (xRateOfSeries tK tA xS)        -- +                (xRateOfSeries tP tK tA xS)  --                  xF                              -- loop body          -- 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 tenv tK+        , xS                            <- XVar (UName nS)         = Just         $ xNewVector                 tA-                (xNatOfRateNat tK $ xRateOfSeries tK tS xS)+                (xNatOfRateNat tK $ xRateOfSeries tP tK tS xS)                          | otherwise         = Nothing@@ -93,33 +93,33 @@  ------------------------------------------------------------------------------- -- | Search the given environment for the name of a series with the---   given rate parameter. We only look at named binders.+--   given result rate parameter. We only look at named binders. findSeriesWithRate          :: TypeEnvF             -- ^ Type Environment.         -> Type Name            -- ^ Rate type.-        -> Maybe (Name, Type Name, Type Name)-                                -- ^ Series name, rate type, element type.-findSeriesWithRate tenv tR+        -> Maybe (Name, Type Name, Type Name, Type Name)+        -- ^ Series name, process, result rate, element type.+findSeriesWithRate tenv tK  = go (Map.toList (Env.envMap tenv))  where  go []           = Nothing         go ((n, tS) : moar)-         = case isSeriesTypeOfRate tR tS of-                Nothing         -> go moar-                Just (_, tA)    -> Just (n, tR, tA)+         = 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

@@ -6,6 +6,7 @@ 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.Module@@ -27,15 +28,31 @@  -- | Extract code for a whole procedure. extractProcedure  :: Procedure -> (Bind Name, ExpF)-extractProcedure (Procedure n bsParam xsParam nest)- = let  tBody   = foldr tFun    tUnit $ map typeOfBind xsParam-        tQuant  = foldr TForall tBody $ bsParam-   in   ( BName n tQuant-        ,   xLAMs bsParam-          $ xLams xsParam+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 @@ -52,7 +69,7 @@ extractLoop      :: Nest -> [LetsF]  -- Code in the top-level loop context.-extractLoop (NestLoop tRate starts bodys inner ends _result)+extractLoop (NestLoop tRate starts bodys inner ends)  = let           -- Starting statements.         lsStart = concatMap extractStmtStart starts@@ -81,19 +98,15 @@    in   lsStart ++ [lLoop] ++ lsEnd  -- Code in a guard context.-extractLoop (NestGuard _tRateOuter tRateInner uFlags stmtsBody nested)+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) -        -- Get the name of the entry counter.-        TVar (UName nK) = tRateInner-        uCounter        = UName (NameVarMod nK "count")--        xBody           = xGuard (XVar uCounter) xFlag -                          (  XLam (BAnon tNat)+        xBody           = xGuard xFlag +                          (  XLam (BNone tUnit)                           $ xLets (lsBody ++ lsNested) xUnit)          -- Statements in the guard context.@@ -105,20 +118,15 @@   in    [LLet (BNone tUnit) xBody]  -- Code in a segment context.-extractLoop (NestSegment _tRateOuter tRateInner uLengths stmtsBody nested)+extractLoop (NestSegment _tRateOuter _tRateInner uLengths stmtsBody nested)  = let         -- Get the name of a single segment length from the series of lengths.         UName nLengths  = uLengths         nLength         = NameVarMod nLengths "elem"         xLength         = XVar (UName nLength) -        -- Get the name of the entry counter.-        TVar (UName nK) = tRateInner-        uCounter        = UName (NameVarMod nK "count")--        xBody           = xSegment (XVar uCounter) xLength +        xBody           = xSegment xLength                          (  XLam (BAnon tNat)    -- Index into current segment.-                        $  XLam (BAnon tNat)    -- Index into overall result series.                         $ xLets (lsBody ++ lsNested) xUnit)          -- Statements in the segment context.@@ -170,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@@ -198,11 +206,9 @@                   (xRead t (XVar (UName nAcc))) ]          -- Truncate a vector down to its final size.-        EndVecTrunc nVec tElem tRate +        EndVecTrunc nVec tElem uCounter           -> let                  -- Get the name of the counter.-                TVar (UName nK) = tRate-                uCounter        = UName (NameVarMod nK "count")                 xCounter        = xRead tNat (XVar uCounter)                 xVec            = XVar (UName nVec) 

@@ -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+

@@ -9,7 +9,7 @@ import DDC.Core.Module import DDC.Core.Transform.Annotate import DDC.Core.Transform.Deannotate-import Control.Monad.Writer.Strict+import Control.Monad.Writer.Strict      hiding (Alt(..)) import qualified Data.Set               as Set import Data.Set                         (Set) @@ -153,14 +153,16 @@ instance Melt (Lets () Name) where  melt lts   = case lts of-        LLet b x        -> liftM (LLet b) (melt x)+        LLet b x+         -> liftM (LLet b) (melt x)+         LRec bxs                  -> do  let (bs, xs) = unzip bxs                 xs'      <- mapM melt xs                 return   $  LRec $ zip bs xs' -        LPrivate{}      -> return lts-        LWithRegion{}   -> return lts+        LPrivate{}+         -> return lts   -- Alt ------------------------------------------------------------------------

@@ -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+

@@ -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++

@@ -0,0 +1,126 @@+module DDC.Core.Flow.Transform.Rates.Clusters.Greedy+    (cluster_greedy)+ where++import DDC.Base.Pretty+import DDC.Core.Flow.Transform.Rates.Graph+import DDC.Core.Flow.Transform.Rates.Clusters.Base++cluster_greedy :: (Ord n, Eq t, Show n, Pretty n) => 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+

@@ -0,0 +1,320 @@+{-# LANGUAGE DataKinds #-}+module DDC.Core.Flow.Transform.Rates.Clusters.Linear+    (solve_linear)+ where++import DDC.Base.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, Show n)+               => 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, Show n) => 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"+

@@ -0,0 +1,205 @@+module DDC.Core.Flow.Transform.Rates.CnfFromExp+        (cnfOfExp, takeXLamFlags_safe) where+import DDC.Core.Collect+import DDC.Core.Flow.Compounds+import DDC.Core.Flow.Prim+import DDC.Core.Flow.Exp+import DDC.Core.Flow.Transform.Rates.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+

@@ -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.Base.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 a) => Pretty (Fun s a) where+ ppr (Fun _ ss)+  = encloseSep lbrace rbrace space+  $ map ppr ss++instance (Pretty s, Pretty a) => 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

@@ -1,351 +0,0 @@-module DDC.Core.Flow.Transform.Rates.Constraints-        ( Constraint(..)-        , ConstraintMap, EquivClass-        , canonName-        , checkBindConstraints-        , getMaxSize )-where-import DDC.Core.Flow.Compounds-import DDC.Core.Flow.Prim-import DDC.Core.Flow.Exp-import DDC.Core.Flow.Transform.Rates.Fail-import Control.Monad-import qualified Data.Map               as Map-import qualified Data.Set               as Set------ | Constraint information--- An equal can have multiple - eg map3--- Filtered only has its source input-data Constraint- = ConEqual     [Name]- | ConFiltered   Name- deriving (Eq,Show)--type ConstraintMap = Map.Map Name Constraint-type EquivClass    = [Set.Set Name]----- | Get canonical name for given equivalence class--- Return original if there is none--- (for example, a filter with no maps applied would have none since equiv classes are only built from maps)-canonName :: EquivClass -> Name -> Name-canonName equivs n- = case equivSet equivs n of-    Nothing -> n-    Just s  -> Set.findMin s----- | Get set of associated names in given equivalence class-equivSet :: EquivClass -> Name -> Maybe (Set.Set Name)-equivSet equivs n = go equivs- where-  -- No classes left, not found-  go []-   = Nothing--  -- If @n@ is a member of this class, return it-  go (c:cs')-   | Set.member n c-   = Just c--   -- Check the rest -   | otherwise-   = go cs'----- | Check constraints for a single function body's bindings.--- The bindings must be in a-normal form.-checkBindConstraints :: [(Name,ExpF)] -> LogFailures (ConstraintMap, EquivClass)-checkBindConstraints binds- = -- Generate all constraints-   let constrs       = getConstraints binds-   -- Squash down eqs into equivalence classes-       equivs        = equivConstrs   constrs-   -- Get filter constraints as pairs-       filts         = filterConstrs  constrs equivs--   -- Check for ill-formed constraints:-   --      Filter "a <= a" is bad, as restricts to a=a-   --      Filter "a <= b" and "a <= c" is bad because 'a' mentioned twice in lhs-   in   checkFilters filts >> return (constrs, equivs)---getMaxSize :: ConstraintMap -> EquivClass -> [Name] -> Name -> Name-getMaxSize constrs equivs mans get- = let get' = upFiltered get-   in  getFromMans get'- where-  -- Keep moving up through filtered constraints until we hit the top-  upFiltered g-   | Just eqs <- equivSet equivs g-   = upFiltered' g (Set.toList eqs)-   | otherwise-   = g--  upFiltered' g []-   = g-  upFiltered' g (e:es)-   | Just (ConFiltered g') <- Map.lookup e constrs-   = upFiltered g'-   | otherwise-   = upFiltered' g es--  -- Find a manifest vector in the same equivalence class-  getFromMans g-   = let e = canonName equivs g-     in  getFromMans' e mans--  getFromMans' g []-   = g-  getFromMans' g (m:ms)-   | g == canonName equivs m-   = m-   | otherwise-   = getFromMans' g ms-   - ---- | Squash constraints into equivalence classes--- I'm sure this could be smarter.-equivConstrs :: ConstraintMap -> EquivClass-equivConstrs m- = let sets = filter (not . Set.null)-            $ map gen-            $ Map.toList m-   in  squash sets []- where-  -- Simply generate a set from each constraint-  gen (k, (ConEqual eqs))-   = Set.fromList (k:eqs)-  -- Ignore filter constraints-  gen (k, (ConFiltered _from))-   = Set.singleton k--  -- Squash constraint sets together-  squash []     acc-   = acc--  squash (a:as) acc-   -- Try to merge the @a@ set into @acc@ somewhere-   -- If so, start merging the whole thing again-   | Just merged <- squash_merge a acc-   = squash (merged ++ as) []--   -- Nothing in @a@ is mentioned in @acc@, so no merging required:-   --   just add this set to the accumulator-   | otherwise-   = squash as (a:acc)--  squash_merge ins (s:ss)-   -- Check if any members of @ins@ are mentioned in @s@-   -- If so, merge them into one equivalence class-   | not $ Set.null $ ins `Set.intersection` s-   = Just (ins `Set.union` s : ss)--   -- Check if there is a chance to merge later-   | Just ss' <- squash_merge ins ss-   = Just (s : ss')--  -- No merge is possible-  squash_merge _ins _ss-   = Nothing----- Get canonical names of all filter constraints-filterConstrs :: ConstraintMap -> EquivClass -> [(Name,Name, Name, Name)]-filterConstrs m equivs = Map.foldWithKey go [] m- where-  go k (ConFiltered src) ms-   = (canonName equivs k, canonName equivs src, k, src) : ms-  go _  _                ms-   = ms----- | Generate constraints map from bindings-getConstraints :: [(Name,ExpF)] -> ConstraintMap-getConstraints lets- = foldl go Map.empty lets- where-  go m (n,x)-   | Just (n',c) <- getConstraint n x -   = Map.insert n' c m-   | otherwise-   = m--getConstraint :: Name -> ExpF -> Maybe (Name, Constraint)-getConstraint n xx- | Just (f, args)                   <- takeXApps xx- , XVar (UPrim (NameOpVector ov) _) <- f- = case ov of-   OpVectorMap i-    -- Args:-    -- map1 :: [a b   : *]. (a -> b)      -> Vector a -> Vector b-    -- (drop 3)-    -- map2 :: [a b c : *]. (a -> b -> c) -> Vector a -> Vector b -> Vector c-    -- (drop 4)-    | vecs         <- drop (i+2) args-    -- Must be fully applied-    , length vecs  == i-    , names        <- getNames vecs-    -- Each name must also be a bound variable-    , length names == i-    -> Just (n, ConEqual names)--   OpVectorFilter-    | [_tyA, _p, XVar (UName vec)] <- args-    -> Just (n, ConFiltered vec)--   OpVectorGenerate-   -- Not really sure about this-    -> Just (n, ConEqual [])--   OpVectorReduce-    | [_tyA, _f, _z, XVar (UName vec)] <- args-    -> Just (n, ConEqual [vec])--   OpVectorLength-    | [_tyA, XVar (UName vec)] <- args-    -> Just (n, ConEqual [vec])--   _-    -> Nothing-- | otherwise- = Nothing---- | Get bound name for each expression--- All expressions must be variables of bound names,--- otherwise result list will be shorter than input.-getNames :: [ExpF] -> [Name]-getNames vs- = concatMap get vs- where-  get x-   | XVar (UName v) <- x-   = [v]-   | otherwise-   = []----- | Check for ill-formed constraints:-------      Filter 'a <= a' is bad, as restricts to 'a=a'---      Filter 'a <= b' and 'a <= c' is bad because a mentioned twice in lhs--- For some filter--- > bs = filter p as--- the arguments are--- > (canon bs, canon as,  bs, as)--- the 'raw' variable names bs and as are only used for error messages;--- comparisons are done on canonical names.-checkFilters :: [(Name,Name, Name,Name)] -> LogFailures ()-checkFilters cs- = go cs- where-  go []-   = return ()-  go ((lc,rc, ln, rn):cs')-   = do when (lc == rc) $-          warn $ FailConstraintFilteredLessFiltered ln rn-        -- Check against later ones-        forM_ cs' $ \(lc', _, ln', _) ->-          when (lc == lc') $-            warn $ FailConstraintFilteredNotUnique  ln ln'--        go cs'----{---f = \(as : Vector a).-    as'    = vmap [:a b:] g as-    return as'--==>-[as=as']-==>--f = \(as : Vector a).-    runSeries as /\(k1 : Rate). \(asS : Series k1 a).-    as'    = valloc [:k1 b:]-    as'S   = smap   [:k1 a b:] g asS-    sfill [:k1 b:] as' as'S-    return as'-------f = \(as : Vector a).-    as'    = vmap [:a b:] g as-    as''   = vmap [:b b:] h as'-    return as''--==>-[as = as' = as'']-==>--f = \(as : Vector a).-    runSeries as /\(k1 : Rate). \(asS : Series k1 a).-    as'S   = smap   [:k1 a b:] g asS-    as''   = valloc [:k1 c:]-    as''S  = smap   [:k1 b c:] h as'S-    sfill [:k1 b:] as'' as''S-    return as''-------f = \(as : Vector a).-    as' = filter p as-    n   = length   as'-    ns  = map (/n) as'--==>-[as' <= as-,ns   = as']-==>--f = \(as : Vector a).-    runSeries as /\(k1 : Rate). \(asS : Series k1 a).-    as'F = smap [:k1 a Bool:] p asS-    mkSel [:k1:] as'F /\(k2 : Rate). \(as'Se : Sel k1 k2).-    as'S = spack   [:k1 k2 a:] as'Se asS-    n    = slength [:k2:]-    nsS  = smap    [:k2 a a:] (/n) as'S-    ns   = valloc  [:k2 a:]-    sfill [:k2 a:] ns nsS--    return ns-------f = \(as : Vector a).-    bs = filter p as-    cs = map2   f as bs-    return cs--==>-[bs <= as-,cs = as = bs]-==>-[as <= as]-Error!-------f = \(as bs : Vector a).-    cs = filter p as-    ds = filter p bs-    es = map2   f cs ds-    return es--==>-[cs <= as-,ds <= bs-,cs=ds=es]-==>-[cs <= as-,cs <= bs]-Error, cs mentioned twice in lhs!--}-

@@ -1,5 +1,6 @@ module DDC.Core.Flow.Transform.Rates.Fail         ( Fail (..)+        , ConversionError (..)         , LogFailures         , warn, run) where@@ -8,9 +9,8 @@ import Control.Monad.Writer import Data.List ---- | Why can't rates be inferred?-data Fail+-- | Why couldn't it be converted to CNF?+data ConversionError         -- | Function is not in a-normal form         = FailNotANormalForm @@ -20,12 +20,21 @@         -- | 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 

@@ -1,24 +1,24 @@ module DDC.Core.Flow.Transform.Rates.Graph-        ( Graph+        ( Graph(..)         , Edge         , graphOfBinds         , graphTopoOrder          , mergeWeights-        , traversal         , invertMap-        , mlookup )+        , numNodes, numEdges+        , hasNode, hasEdge+        , nodeInputs, nodeInEdges+        , nodeType+        , listOfGraph, graphOfList ) where-import DDC.Core.Collect-import DDC.Core.Flow.Compounds-import DDC.Core.Flow.Prim-import DDC.Core.Flow.Exp-import qualified DDC.Type.Env           as Env+import DDC.Core.Flow.Transform.Rates.Combinators+import DDC.Core.Flow.Transform.Rates.SizeInference -import           Data.List              (intersect, nub)+import           Data.List              (nub) import qualified Data.Map               as Map-import           Data.Maybe             (catMaybes) import qualified Data.Set               as Set + -- | Graph for function --   Each node is a binding, edges are dependencies, and the bool is whether the node's output --   can be fused or contracted.@@ -26,58 +26,64 @@ --   but a fold cannot as it must consume the entire stream before producing output. -- -type Edge  = (Name, Bool)-type Graph = Map.Map Name [Edge]+type Edge  n   = (n, Bool)+data Graph n t = Graph (Map.Map n (Maybe t, [Edge n])) -graphOfBinds :: [(Name,ExpF)] -> [Name] -> Graph-graphOfBinds binds extra_names- = Map.map mkEdges graph1- where-  mkEdges (refs, _fusible)-   = map getFusible refs-  -  getFusible r-   | Just (_,f) <- Map.lookup r graph1-   = (r, f)-   | otherwise-   = (r, True) -  graph1+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+   $ _binds prog -  gen (k, xx)-   = let free = catMaybes-              $ map takeNameOfBound-              $ Set.toList-              $ freeX Env.empty xx-         refs = free `intersect` names-     in  (k, (refs, fusible xx))+  gen b+   = let n    = cnameOfBind b+         ty   = iter prog env n+         es   = edges n b+     in (n, (ty, es)) -  names = map fst binds ++ extra_names+  edges n (ABind _ (Gather a b))+   = let a' = mkedgeA (const False) a+         b' = mkedgeA (inedge n)    b+     in [a', b'] -  fusible xx-   | Just (f, _)                      <- takeXApps xx-   , XVar (UPrim (NameOpVector ov) _) <- f-   = case ov of-     OpVectorReduce-      -> False-     -     -- Length of `concrete rate' is known before iteration, so should be contractible.-     OpVectorLength-      -> False-     _-      -> True+  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 :: Graph -> [Name]-graphTopoOrder graph+graphTopoOrder :: Ord n => Graph n t -> [n]+graphTopoOrder (Graph graph)  = reverse $ go ([], Map.keysSet graph)  where   go (l, s)@@ -89,8 +95,8 @@    visit (l,s) m    | Set.member m s-   = let edges    = mlookup "visit" graph m-         pres     = map fst edges+   , (_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'')@@ -100,31 +106,15 @@   -traversal :: Graph -> (Edge -> Name -> Int) -> Map.Map Name Int-traversal graph weight- = foldl go Map.empty- $ graphTopoOrder graph- where-  go m node-   = let pres  = mlookup "traversal" graph node--         get e@(u,_)-          | Just v <- Map.lookup u m-          = v + weight e node-          | otherwise-          = 0--         w     = foldl max 0-               $ map get-               $ pres--     in  Map.insert node w m---mergeWeights :: Graph -> Map.Map Name Int -> Graph-mergeWeights graph weights- = foldl go Map.empty- $ graphTopoOrder graph+-- | 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@@ -134,17 +124,21 @@    = merge node node m    merge node k m-   | Just edges <- Map.lookup node graph+   | Just (_ty,edges) <- Map.lookup node graph    = let edges' = nub $ map (\(n,f) -> (name n, f)) edges-     in  Map.insertWith (\x y -> nub $ x ++ y) k edges' m+     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'@@ -160,11 +154,76 @@   go k v m' = Map.insertWith (++) v [k] m'  -mlookup :: Ord k => String -> Map.Map k v -> k -> v-mlookup str m k- | Just v <- Map.lookup k m- = v+-- | 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- = error ("ddc-core-flow.mlookup: no key " ++ str)+ = [] ++-- | 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 :: Ord n => 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 

@@ -1,3 +1,4 @@+ module DDC.Core.Flow.Transform.Rates.SeriesOfVector         (seriesOfVectorModule         ,seriesOfVectorFunction)@@ -5,22 +6,24 @@ import DDC.Core.Collect import DDC.Core.Flow.Compounds import DDC.Core.Flow.Prim-import DDC.Core.Flow.Exp-import DDC.Core.Flow.Transform.Rates.Constraints+import DDC.Core.Flow.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 qualified DDC.Core.Flow.Transform.Rates.SizeInference as SI+import DDC.Core.Flow.Transform.Rates.Clusters import DDC.Core.Module import DDC.Core.Transform.Annotate import DDC.Core.Transform.Deannotate import qualified DDC.Type.Env           as Env -import           Control.Applicative-import           Control.Monad-import           Data.List              (intersect, nub)-import qualified Data.Map               as Map-import           Data.Maybe             (catMaybes)-import qualified Data.Set               as Set+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)@@ -29,454 +32,501 @@        (lets, xx) = splitXLets body        letsErrs   = map seriesOfVectorLets lets -       lets'      = map       fst letsErrs+       lets'      = concatMap fst letsErrs        errs       = concatMap snd letsErrs         body'      = annotate ()                   $ xLets lets' xx  -   in  -- trace ("ORIGINAL:"++ show (ppr $ moduleBody mm))-       -- trace ("MODULE:" ++ show (ppr body'))-       (mm { moduleBody = body' }, errs)+   in  (mm { moduleBody = body' }, errs)          -seriesOfVectorLets :: LetsF -> (LetsF, [(Name,Fail)])+seriesOfVectorLets :: LetsF -> ([LetsF], [(Name,Fail)]) seriesOfVectorLets ll  | LLet b@(BName n _) x <- ll- , (x',errs)  <- seriesOfVectorFunction x- = (LLet b x', map (\f -> (n,f)) errs)+ , (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',_errs)          <- unzip $ map seriesOfVectorFunction xs- = (LRec (bs `zip` xs'), []) + , (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, [])+ = ([ll], [])   -- | Takes a single function body. Function body must be in a-normal form.-seriesOfVectorFunction :: ExpF -> (ExpF, [Fail])+seriesOfVectorFunction :: ExpF -> (ExpF, [(BindF,ExpF)], [Fail]) seriesOfVectorFunction fun- = run $ do-        -- Peel off the lambdas-        let (lams, body)   = takeXLamFlags_safe fun-        -            -- This assumes the body is already in a-normal form.-            (lets, xx)     = splitXLets         body-        -        -- Split into name and values and warn for recursive bindings-        binds             <- takeLets           lets-        let tymap          = takeTypes          (concatMap valwitBindsOfLets lets ++ map snd lams)+ = case cnfOfExp fun of+   Left err+    -> (fun, [], [FailCannotConvert err])+   Right prog+    -> case SI.generate prog of+           Nothing+            -> (fun, [], []) -        -- Assumes the binds only use vector primitives,-        -- OR   if not vector primitives, do not refer to bound vectors+           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, []) -        let names = map fst binds-        -- Make sure names are unique-        when (length names /= length (nub names)) $-          warn FailNamesNotUnique -        (constrs, equivs)-                  <- checkBindConstraints binds+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 -        let extras = catMaybes-                   $ map (takeNameOfBind . snd) lams-        let graph  = graphOfBinds         binds extras+  (lams, body)   = takeXLamFlags_safe fun+  (olds, xx)     = splitXLets         body -        let rets   = catMaybes-                   $ map takeNameOfBound-                   $ Set.toList-                   $ freeX Env.empty xx-        -        loops     <- schedule             graph equivs rets+  types          = takeTypes          (concatMap valwitBindsOfLets olds ++ map snd lams) -        binds'    <- orderBinds           binds loops+  lets           = concatMap convert clusters+  (lets', procs) = extractProcs lets lams -        -- True <- trace ("TYMAP:" ++ show tymap) return True-        -- True <- trace ("NAMES,LOOPS,NAMES':" ++ show (names, loops, map (map fst) binds')) -        --         return True+  convert c+   = let outputs = outputsOfCluster prog c -        let outputs = map lOutputs loops-        let inputs  = map lInputs  loops+         arrIns  = seriesInputsOfCluster prog c -        let getMax  = getMaxSize constrs equivs extras+         -- 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' -        return $ construct getMax lams (zip3 binds' outputs inputs) equivs tymap xx --- | Peel the lambdas off, or const if there are none-takeXLamFlags_safe x- | Just (binds, body) <- takeXLamFlags x- = (binds, body)- | otherwise- = ([],    x)+-- | 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 --- | Split into name and values and warn for recursive bindings-takeLets :: [LetsF] -> LogFailures [(Name, ExpF)]-takeLets lets- = concat <$> mapM get lets- where-  get (LLet (BName n _) x) = return [(n,x)]-  get (LLet (BNone _)   _) = return []-  get (LLet (BAnon _)   _) = w      FailNoDeBruijnAllowed-  get (LRec        _     ) = w      FailRecursiveBindings-  get (LPrivate _ _ _)     = w      FailLetRegionNotHandled-  get (LWithRegion _     ) = w      FailLetRegionNotHandled+   | otherwise+   = ([l],[]) `mappend` go ls e -  w err                    = warn err >> return []+  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) --- | Split into name and values and warn for recursive bindings-takeTypes :: [Bind Name] -> Map.Map Name TypeF-takeTypes binds- = Map.fromList $ concatMap get binds- where-  get (BName n t) = [(n,t)]-  get _           = []+   | 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 -data Loop- = Loop - { lBindings :: [Name]- , lOutputs  :: [Name]- , lInputs   :: [Name]- } deriving (Eq,Show)+         isMentioned (ty,bo)+          | Just bo' <- takeSubstBoundOfBind bo+          = if   ty+            then Set.member bo' fsT+            else Set.member bo' fsX+          | otherwise+          = False -schedule :: Graph -> EquivClass -> [Name] -> LogFailures [Loop]-schedule graph equivs rets- = let type_order    = map (canonName equivs . Set.findMin) equivs-       -- minimumBy length $ map scheduleTypes $ permutations type_order-       (wts, graph') = scheduleTypes graph equivs type_order-       loops         = scheduleAll (map snd wts) graph graph'-       -- Use the original graph to find vars that cross loop boundaries-       outputs       = scheduleOutputs loops graph rets-       inputs        = scheduleInputs  loops graph-   in  -- trace ("GRAPH,GRAPH',WTS,EQUIVS:" ++ show (graph, graph', wts, equivs)) -       return $ zipWith3 Loop loops outputs inputs+         os = filter isMentioned e -scheduleTypes :: Graph -> EquivClass -> [Name] -> ([(Name, Map.Map Name Int)], Graph)-scheduleTypes graph types type_order- = foldl go ([],graph) type_order- where-  go (w,g) ty-   = let w' = typedTraversal g types ty-         g' = mergeWeights   g w'-     in  ((ty,w') : w, g')+         ss  = takeSubstBoundsOfBinds . map snd+         osT = filter     (fst) os+         osX = filter (not.fst) os +         nm' = NameVarMod nm "process" -scheduleAll :: [Map.Map Name Int] -> Graph -> Graph -> [[Name]]-scheduleAll weights graph graph'- = loops- where-  weights' = map invertMap  weights-  topo     = graphTopoOrder graph'-  loops    = map getNames topo+         x' = xApps op (xs +++                [xApps (XVar $ UName nm')+                  (  map (XType . TVar) (ss osT)+                  ++ map  XVar          (ss osX))]) -  getNames n-   = sort $ find n (weights `zip` weights')+         p' = makeXLamFlags (osT ++ osX) lam+     in ([LLet b x'], [(BName nm' (tBot kData),  p')]) -  original_order = graphTopoOrder graph+   | otherwise+   = ([LLet b x], []) -  -- Cheesy hack to get ns in same order as the original graph's topo:-  -- filter topo to only those elements in ns-  sort ns-   = filter (flip elem ns) original_order+-- | 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] -  find _ []-   = []+    _    -> 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) -  find n ((w,w') : rest)-   | Just i  <- n `Map.lookup` w-   , Just ns <- i `Map.lookup` w'-   = ns+ -- 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-   = find n rest+ | otherwise+ = process types env arrIns+ $ map toEither bs --- Find any variables that cross loop boundaries - they must be reified-scheduleOutputs :: [[Name]] -> Graph -> [Name] -> [[Name]]-scheduleOutputs loops graph rets- = map output loops  where-  output ns-   = graphOuts ns ++ filter (`elem` ns) rets +  isExt (Ext{}) = True+  isExt _       = False -  graphOuts ns-   = concatMap (\(k,es) -> if   k `elem` ns-                           then []-                           else ns `intersect` map fst es)-   $ Map.toList graph+  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!" --- Find any variables that cross loop boundaries - they must be reified-scheduleInputs  :: [[Name]] -> Graph -> [[Name]]-scheduleInputs  loops graph- = map input loops++-- | 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-  input ns-   = filter (\n -> not (n `elem` ns))-   $ graphIns ns+  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)] -  graphIns ns-   = nub $ concatMap (map fst . mlookup "graphIns" graph) ns+   -- Returned vectors+   | ((v, Right _), True)                       <- b+   = [LLet (BName v $ tVector $ sctyOf v) (xNewVector (sctyOf v) allocSize)] -typedTraversal :: Graph -> EquivClass -> Name -> Map.Map Name Int-typedTraversal graph types current_type- = restrictTypes types current_type- $ traversal graph w- where-  w  u v = if w' u v then 1 else 0+   -- Otherwise, it's not returned or we needn't allocate anything+   | _                                          <- b+   = [] -  w' (u, fusible) v-   | canonName types u == current_type-   = canonName types v /= current_type || not fusible +  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-   = False+   = getGenerates rest innerX +  getRateVecs [] innerX+   = innerX -restrictTypes :: EquivClass -> Name -> Map.Map Name Int -> Map.Map Name Int-restrictTypes types current_type weights- = Map.filterWithKey restrict weights- where-  restrict n _-   = canonName types n == current_type+  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 -orderBinds :: [(Name,ExpF)] -> [Loop] -> LogFailures [[(Name,ExpF)]]-orderBinds binds loops- = let bindsM = Map.fromList binds-       order  = map lBindings loops-       get k  | Just v <- Map.lookup k bindsM-              = [(k,v)]-              | otherwise-              = []-   in  return $ map (\o -> concatMap get o) order+   , 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' ]+       ) -construct-        :: (Name -> Name)-        -> [(Bool, BindF)]-        -> [([(Name, ExpF)], [Name], [Name])]-        -> EquivClass-        -> Map.Map Name TypeF-        -> ExpF-        -> ExpF-construct getMax lams loops equivs tys xx- = let lets   = concatMap convert loops-   in  makeXLamFlags lams-     $ xLets lets-     $ xx- where-  convert (binds, outputs, inputs)-   = convertToSeries getMax binds outputs inputs equivs tys+   -- 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" ] ) --- We still need to join procs,--- split output procs into separate functions-convertToSeries -        :: (Name -> Name) -> [(Name,ExpF)] -> [Name] -> [Name] -        -> EquivClass -> Map.Map Name TypeF -> [LetsF] -convertToSeries getMax binds outputs inputs equivs tys- =  concat setups- ++ [LLet (BNone tBool) (runprocs inputs' processes)]- ++ concat readrefs- where-  runprocs :: [(Name,TypeF)] -> ExpF -> ExpF-  runprocs vecs@((cn,_):_) body-   = let cnn    = canonName equivs cn-         kN     = NameVarMod cnn "k"-         kFlags = [ (True,  BName kN kRate)-                  , (False, BNone $ tRateNat $ TVar $ UName kN)]-         vFlags = map (\(n,t) -> (False, BName (NameVarMod n "s") (tSeries (TVar (UName kN)) t)))-                        vecs-     in  xApps (xVarOpSeries (OpSeriesRunProcess $ length vecs))-               (  map (XType .         snd) vecs-               ++ map (XVar  . UName . fst) vecs-               ++ [(makeXLamFlags (kFlags ++ vFlags) body)]) -  -- Should we introduce a rate parameter for generates?-  runprocs [] body-   = body--  inputs' :: [(Name,TypeF)]-  inputs' = concatMap filterInputs inputs+  getPost b+   | ((s, Left (Fold _ (Scalar _ _) _)), _)       <- b+   = [ LLet (BName s $ sctyOf s) (xRead (tyOf s) (var $ NameVarMod s "ref")) ] -  filterInputs inp-   | tyI <- mlookup "collectKloks" tys inp-   , Just (_tcVec, [tyA]) <- takeTyConApps tyI-   , tyI == tVector tyA-   = [(inp, tyA)]-   | otherwise+   -- Ignore anything else+   | _   <- b    = [] -  processes -   = foldr wrap joins binds+  runProcs body+   = let flags = [ (True,  BName procName kProc)+                 , (False, BNone tUnit) ]+     in  xApps (xVarOpSeries OpSeriesRunProcess)+               ([XType processRate, makeXLamFlags flags body]) -  wrap (n,x) body-   = wrapSeriesX equivs outputs n (mlookup "wrap" tys n) x body -  joins-   | not $ null outputs-   = foldl1 mkJoin-   $ map (\n -> XVar $ UName $ NameVarMod n "proc") outputs+  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-   = xUnit -- ???+   = 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] -  -- fill vectors and read references-  (setups, readrefs)-   = unzip-   $ map setread -   $ filter (flip elem outputs . fst) binds+  getProc b@((s, Left _), _)+   = [resizeProc b $ var $ NameVarMod s "proc"]+  getProc b@((a, _), True)+   = [resizeProc b $ var $ NameVarMod a "proc"]+  getProc _+   = [] -  setread (n,x)-   = setreadSeriesX getMax tys n (mlookup "setread" tys n) x+  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." -setreadSeriesX -        :: (Name -> Name) -> Map.Map Name TypeF -> Name -> TypeF -> ExpF -> ([LetsF], [LetsF])-setreadSeriesX getMax tys name ty xx- | Just (f, args)                       <- takeXApps xx- , XVar (UPrim (NameOpVector ov) _)     <- f- = case ov of-   -- any folds MUST be known as outputs, so this is safe-   OpVectorReduce-    | [_tA, _f, z, _vA]   <- args-    -> ([ LLet (BName (nm "ref") (tRef ty)) (xNew  ty z) ]-       ,[ LLet (BName  name       ty)       (xRead ty (vr $ nm "ref"))])+      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 -   _-    | [_vec, tyR]       <- takeTApps ty-    , v                 <- getMax name -- canonName equivs name-    , [_vec, tyCR]      <- takeTApps $ mlookup "setreadSeriesX" tys v-    -> let vl = xApps (xVarOpVector OpVectorLength)-                      [XType tyCR, XVar $ UName v]-       in  ([ LLet (BName name $ tBot kData) $ xNewVector tyR vl ]-           ,  [])+      Right (Generate _ _)+       -> v -   _-    -> ([], [])- | otherwise- = ([],[])- where-  nm s = NameVarMod name s-  vr n = XVar $ UName n+      Right (Gather _ ain)+       -> goResize ain v rest +      Right (Cross a _b)+       -> goResize a v rest -wrapSeriesX :: EquivClass -> [Name] -> Name -> TypeF -> ExpF -> ExpF -> ExpF-wrapSeriesX equivs outputs name ty xx wrap- | Just (op, args)                      <- takeXApps xx- , XVar (UPrim (NameOpVector ov) _)     <- op- = case ov of-   OpVectorReduce-    | [_tA, f, z, vA]   <- args-    , XVar (UName nvA)  <- vA-    , kA                <- klok nvA-    -> XLet (LLet (BName name'proc tProcess)-                 $ xApps (xVarOpSeries OpSeriesReduce)-                         [kA, XType ty, XVar (UName name'ref), f, z, modNameX "s" vA])-             wrap+   | otherwise+   = goResize n v rest -   OpVectorMap n-    | (tys, f : rest) <- splitAt (n+1) args-    , length rest     == n-    , kT              <- klok name-    , rest'           <- map (modNameX "s") rest-    -> XLet (LLet (BName name's $ tBot kData)-                 $ xApps (xVarOpSeries (OpSeriesMap n))-                         ([kT] ++ tys ++ [f] ++ rest'))-             wrap'fill+     +  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) -   OpVectorFilter-    | [tA, p, vA]       <- args-    , XVar (UName nvA)  <- vA-    , tkA               <- klokT nvA-    , kA                <- klok nvA-    , TVar (UName nkT)  <- klokT name-    , tkT               <- klokT name-    -> XLet (LLet (BName name'flags (tBot kData))-                 $ xApps (xVarOpSeries (OpSeriesMap 1))-                         ([kA, tA, XType tBool, p, modNameX "s" vA]))-     $ xApps (xVarOpSeries (OpSeriesMkSel 1))-             ([kA, XVar (UName name'flags)-              ,    XLAM (BName nkT       kRate)-                 $ XLam (BName name'sel (tSel1 tkA tkT))-                 $ XLet (LLet (BName name's (tBot kData))-                             $ xApps (xVarOpSeries OpSeriesPack)-                                     ([kA, XType tkT, tA, XVar (UName name'sel), modNameX "s" vA]))-                         wrap'fill ])+  -- 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) -   _-    -> xx- | otherwise- = xx+  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 - where-  name'flags= NameVarMod name "flags"-  name'proc = NameVarMod name "proc"-  name'ref  = NameVarMod name "ref"-  name's    = NameVarMod name "s"-  name'sel  = NameVarMod name "sel"+  -- We just need a name for the Proc type+  procName = NameVarMod outname "PROC"+  procT    = TVar  $ UName $ procName+  procX    = XType $ procT -  klokT n-   = let n'  = canonName equivs n-         kN  = NameVarMod n' "k"-     in  TVar $ UName kN-  klok n-   = XType $ klokT n+  klokV = getKlok env+  klokT = TVar . UName . klokV+  klokX = XType . klokT -  tyR-   | [_vec, tyR']        <- takeTApps ty-   = Just tyR'-   | otherwise-   = Nothing+  findGenerateSize ((_, Right (Generate sz _)), _)+   = [sz]+  findGenerateSize _+   = [] -  wrap'fill-   | name `elem` outputs-   , Just tyR' <- tyR-   = XLet (LLet (BName name'proc tProcess) $ xApps fillV [klok name, XType tyR', vr name, vr name's])-           wrap-   | otherwise-   = wrap -  fillV = xVarOpSeries OpSeriesFill+  -- 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 -  vr n = XVar $ UName n+  tyOf n  = types Map.! n+  sctyOf  = getScalarType . tyOf+  xtyOf   = XType . tyOf+  xsctyOf = XType . sctyOf ---  tySeries---   | Vector n+  var n   = XVar $ UName n + xVarOpSeries n = XVar (UPrim (NameOpSeries n) (typeOpSeries n)) xVarOpVector n = XVar (UPrim (NameOpVector n) (typeOpVector n)) -modNameX :: String -> ExpF -> ExpF-modNameX s xx- = case xx of-    XVar (UName n)-     -> XVar (UName (NameVarMod n s))-    _-     -> xx -{-+-- | 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 -\as,bs...-cs = map as-ds = filter as-n  = fold ds-es = map3 bs cs-return es -==>-schedule graph equivs [es]-==>+-- | 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 _           = [] -[ [ds, n]-, [cs, es] ] --}+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) "'"++

@@ -0,0 +1,484 @@+-- | 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.Base.Pretty+import DDC.Core.Flow.Transform.Rates.Combinators++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 :: Ord a => 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 :: Ord a => 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++

@@ -3,16 +3,17 @@         ( elemBindOfSeriesBind         , elemBoundOfSeriesBound         , elemTypeOfSeriesType-        , rateTypeOfSeriesType-        , slurpRateOfParamTypes+        , resultRateTypeOfSeriesType+        , procTypeOfSeriesType -        , elemTypeOfVectorType)+        , rateTypeOfRateVecType++        , elemTypeOfVectorType+        , bufOfVectorName) where-import DDC.Core.Flow.Transform.Schedule.Error import DDC.Core.Flow.Compounds import DDC.Core.Flow.Prim import DDC.Core.Flow.Exp-import Data.Maybe   -- | Given the bind of a series,  produce the bound that refers to the@@ -44,34 +45,48 @@ --   of a single element, namely the @e@. elemTypeOfSeriesType :: TypeF -> Maybe TypeF elemTypeOfSeriesType tSeries'-        | Just (_tcSeries, [_tK, tE]) <- takeTyConApps tSeries'+        | Just (_tcSeries, [_tP, _tK, tE]) <- takeTyConApps tSeries'         = Just tE          | otherwise         = Nothing  --- | Given the type of a series like @Series k e@, produce the type+-- | 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@.-rateTypeOfSeriesType :: TypeF -> Maybe TypeF-rateTypeOfSeriesType tSeries'-        | Just (_tcSeries, [tK, _tE]) <- takeTyConApps tSeries'+rateTypeOfRateVecType :: TypeF -> Maybe TypeF+rateTypeOfRateVecType tV'+        | isRateVecType tV'+        , Just (_tcV, [tK, _tE]) <- takeTyConApps tV'         = Just tK          | otherwise         = Nothing  --- | Given the type of the process parameters, ---   yield the rate of the overall process.-slurpRateOfParamTypes :: [Type Name] -> Either Error (Type Name)-slurpRateOfParamTypes tsParam- = case mapMaybe rateTypeOfSeriesType tsParam of-        []                      -> Left ErrorNoSeriesParameters-        [tK]                    -> Right tK-        (tK : ts)-         | all (== tK) ts       -> Right tK-         | otherwise            -> Left ErrorMultipleRates   -- Vector ---------------------------------------------------------------------@@ -84,3 +99,10 @@          | 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)+

@@ -15,10 +15,6 @@         -- | Process has no rate parameters.         = ErrorNoRateParameters -        -- | Process has no series parameters, -        --   but there needs to be at least one.-        | ErrorNoSeriesParameters-         -- | Process has series of different rates,         --   but all series must have the same rate.         | ErrorMultipleRates@@ -36,6 +32,9 @@         -- | 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@@ -48,9 +47,6 @@         ErrorNoRateParameters          -> vcat [ text "Series process has no rate parameters." ] -        ErrorNoSeriesParameters-         -> vcat [ text "Series process has no series parameters."]-         ErrorMultipleRates          -> vcat [ text "Series process has multiple rate parameters."] @@ -69,6 +65,9 @@          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."

@@ -13,8 +13,7 @@ import DDC.Core.Flow.Compounds import DDC.Core.Flow.Exp import DDC.Core.Flow.Prim-import Control.Monad-import Data.Maybe+import DDC.Core.Flow.Context   -- | Schedule a process kernel into a procedure.@@ -36,60 +35,39 @@ scheduleKernel         lifting        (Process { processName           = name-                , processParamTypes     = bsParamTypes-                , processParamValues    = bsParamValues-                , processOperators      = operators })+                , processParamFlags     = bsParams+                , processContext        = context })  = do   -        -- Check the parameter series all have the same rate.-        tK      <- slurpRateOfParamTypes (map typeOfBind bsParamValues)--        -- Check the primary rate variable matches the rates of the series.-        (case bsParamTypes of-          []            -> Left ErrorNoRateParameters-          BName n k : _ -           | k == kRate-           , TVar (UName n) == tK -> return ()-          _             -> Left ErrorPrimaryRateMismatch)--        -- Lower rates of series parameters.-        let bsParamValues_lowered-                = map (\(BName n t) -                        -> let t' = fromMaybe t $ lowerSeriesRate lifting t-                           in  BName n t')-                $ bsParamValues+        -- 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 -        -- Create the initial loop nest of the process rate.-        let bsSeries    = [ b   | b <- bsParamValues-                                , isSeriesType (typeOfBind b) ]+        let bsParamValues+                = map snd+                $ filter (not.fst)+                $ bsParams -        -- Body expressions that take the next vec of elements from each-        -- input series. If the type can't be lifted this will just throw-        -- a pattern match error.         let c           = liftingFactor lifting-        let ssBody      = [ BodyStmt -                                (BName (NameVarMod nS "elem") tElem_lifted)-                                (xNextC c tK tElem (XVar (UName nS)) (XVar uIndex))-                                | BName nS tS     <- bsSeries-                                , let Just tElem        = elemTypeOfSeriesType tS -                                , let uIndex            = UIx 0 -                                , let Just tElem_lifted = liftType lifting tElem ] -        let nest0       = NestLoop -                        { nestRate      = tDown c tK -                        , nestStart     = []-                        , nestBody      = ssBody-                        , nestInner     = NestEmpty-                        , nestEnd       = []-                        , nestResult    = xUnit }+        let frate r _   = return $ tDown c r+        let fop         = scheduleOperator lifting bsParamValues  -        nest'   <- foldM (scheduleOperator lifting bsParamValues) -                         nest0 operators+        nest <- scheduleContext frate fop context          return  $ Procedure                 { procedureName         = name-                , procedureParamTypes   = bsParamTypes-                , procedureParamValues  = bsParamValues_lowered-                , procedureNest         = nest' }+                , procedureParamFlags   = bsParams_lowered+                , procedureNest         = nest }   -------------------------------------------------------------------------------@@ -97,18 +75,46 @@ scheduleOperator          :: Lifting         -> ScalarEnv-        -> Nest         -- ^ The current loop nest.+        -> FillMap      -- ^ Map of which operators use which write-to accs         -> Operator     -- ^ The operator to schedule.-        -> Either Error Nest+        -> Either Error ([StmtStart], [StmtBody], [StmtEnd]) -scheduleOperator lifting envScalar nest op+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   let c           = liftingFactor lifting-        let tK          = opInputRate op-        let tK_down     = tDown c tK--        -- Bind for the result element.+ = do   -- Bind for the result element.         let Just bResultE =   elemBindOfSeriesBind (opResultSeries op)                           >>= liftTypeOfBind lifting @@ -132,42 +138,39 @@                                         | b <- bsParam_lifted                                         | u <- usInput ] -        let Just nest2  = insertBody nest tK_down-                        $ [ BodyStmt bResultE xBody ]+        let bodies      = [ BodyStmt bResultE xBody ] -        return nest2+        return ([], bodies, [])   -- Fill ----------------------------------------  | OpFill{}     <- op  = do   let c           = liftingFactor lifting-        let tK          = opInputRate op-        let tK_down     = tDown c tK          -- Bound for input element.         let Just uInput = elemBoundOfSeriesBound                          $ opInputSeries op +        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 Just nest2  = insertBody nest tK_down-                        $ [ BodyStmt (BNone tUnit)+        let bodies      = [ BodyStmt (BNone tUnit)                                      (xWriteVectorC c                                         (opElemType op)-                                        (XVar $ opTargetVector op)-                                        (XVar $ UIx 0)+                                        (XVar $ bufOfVectorName $ opTargetVector op)+                                        index                                         (XVar $ uInput)) ] -        -- Bind final unit value.-        let Just nest3  = insertEnds nest2 tK_down-                        $ [ EndStmt  (opResultBind op)-                                     xUnit ]--        return nest3+        return ([], bodies, [])   -- Reduce --------------------------------------  | OpReduce{}   <- op  = do   let c           = liftingFactor lifting-        let tK          = opInputRate op-        let tK_down     = tDown c tK         let tA          = typeOfBind $ opWorkerParamElem op          -- Evaluate the zero value and initialize the vector accumulator.@@ -179,9 +182,8 @@         let nAccVec     = NameVarMod nRef "vec"         let uAccVec     = UName nAccVec -        let Just nest2  -                = insertStarts nest tK_down-                $ [ StartStmt   bAccZero    (opZero op)+        let starts+                = [ StartStmt   bAccZero    (opZero op)                   , StartAcc    nAccVec                                 (tVec c tA)                                 (xvRep c tA (XVar uAccZero)) ]@@ -211,9 +213,8 @@                              x1)                         x2 -        let Just nest3  -                = insertBody nest2 tK_down-                $ [ BodyAccRead  nAccVec (tVec c tA) bAccVal+        let bodies+                = [ BodyAccRead  nAccVec (tVec c tA) bAccVal                   , BodyAccWrite nAccVec (tVec c tA)                                   (xBody_lifted (XVar uAccVal) (XVar uInput)) ] @@ -233,9 +234,8 @@                              x1)                         x2 -        let Just nest4  -                =  insertEnds nest3 tK_down-                $  [ EndStmt    bAccResult+        let ends+                =  [ EndStmt    bAccResult                                 (xRead (tVec c tA) (XVar uAccVec))                     , EndStmt    (BName nAccInit tA)@@ -249,28 +249,22 @@                                 (xBody  (XVar (uPart (i - 1)))                                         (xvProj c i tA (XVar uAccResult)))                                 | i <- [1.. c - 1]]-         -- Write final value to destination.-        let Just nest5  = insertEnds nest4 tK_down-                        $ [ EndStmt    (BNone tUnit)-                                       (xWrite tA (XVar $ opTargetRef op)-                                                  (XVar $ uPart (c - 1))) ]+                ++ [ EndStmt    (BNone tUnit)+                                (xWrite tA (XVar $ opTargetRef op)+                                           (XVar $ uPart (c - 1))) ]         -- Bind final unit value.-        let Just nest6  -                = insertEnds nest5 tK_down-                $ [ EndStmt     (opResultBind op)-                                xUnit ]+                ++ [ EndStmt    (opResultBind op)+                                 xUnit ]  -        return $ nest6+        return (starts, bodies, ends)    -- Gather --------------------------------------  | OpGather{}   <- op  = do            let c           = liftingFactor lifting-        let tK          = opInputRate op-        let tK_down     = tDown c tK          -- Bind for result element.         let Just bResultE =   elemBindOfSeriesBind (opResultBind op)@@ -280,21 +274,19 @@         let Just uIndex = elemBoundOfSeriesBound (opSourceIndices op)          -- Read from vector.-        let Just nest2  = insertBody nest tK_down-                        $ [ BodyStmt bResultE+        let bodies      = [ BodyStmt bResultE                                 (xvGather c +                                        (opVectorRate    op)                                         (opElemType      op)                                         (XVar $ opSourceVector  op)                                         (XVar $ uIndex)) ] -        return nest2+        return ([], bodies, [])   -- Scatter -------------------------------------  | OpScatter{}  <- op  = do            let c           = liftingFactor lifting-        let tK          = opInputRate op-        let tK_down     = tDown c tK          -- Bound of source index.         let Just uIndex = elemBoundOfSeriesBound (opSourceIndices op)@@ -303,19 +295,17 @@         let Just uElem  = elemBoundOfSeriesBound (opSourceElems op)          -- Read from vector.-        let Just nest2  = insertBody nest tK_down-                        $ [ BodyStmt (BNone tUnit)+        let bodies      = [ BodyStmt (BNone tUnit)                                 (xvScatter c                                         (opElemType op)                                         (XVar $ opTargetVector op)                                         (XVar $ uIndex) (XVar $ uElem)) ]          -- Bind final unit value.-        let Just nest3  = insertEnds nest2 tK_down-                        $ [ EndStmt     (opResultBind op)+        let ends        = [ EndStmt     (opResultBind op)                                         xUnit ] -        return nest3+        return ([], bodies, ends)   -- Unsupported ---------------------------------  | otherwise