No more errors, but lots unimplemented

2 files changed, 44 insertions, 40 deletions

diff --git a/SC/Acc.hs b/SC/Acc.hs
index 955c6da..1424f52 100644
--- a/SC/Acc.hs
+++ b/SC/Acc.hs
@@ -6,6 +6,7 @@ import qualified Data.Array.Accelerate.AST as A
 import Data.Array.Accelerate.AST.LeftHandSide
 import Data.Array.Accelerate.AST.Var
 import Data.Array.Accelerate.Representation.Array
+import Data.Array.Accelerate.Representation.Shape hiding (zip)
 import Data.Array.Accelerate.Representation.Type
 import Data.Array.Accelerate.Type
 import Data.Bifunctor
@@ -30,12 +31,12 @@ data Command
 
 insertDeallocs :: [Command] -> [Command]
 insertDeallocs cmds =
-    let allocated = Set.fromList [n | CAlloc _ _ n _ <- cmds]
-                        `Set.union` Set.fromList [n | CKeepalive n <- cmds]
+    let collectable = Set.fromList [n | CAlloc _ _ n _ <- cmds]
+                          `Set.difference` Set.fromList [n | CKeepalive n <- cmds]
     in fst $ foldr
          (\cmd (rest, done) -> case cmd of
               CChunk _ _ used ->
-                  let todealloc = filter (\n -> n `Set.member` allocated &&
+                  let todealloc = filter (\n -> n `Set.member` collectable &&
                                                 n `Set.notMember` done)
                                          used
                   in (cmd : map CDealloc todealloc ++ rest
@@ -43,7 +44,7 @@ insertDeallocs cmds =
               CAlloc _ _ name _
                 | name `Set.notMember` done -> (rest, done)  -- unused alloc
                 | otherwise -> (cmd : rest, Set.delete name done)
-              CKeepalive _ -> (rest, done)  -- already handled above in @allocated@
+              CKeepalive _ -> (rest, done)  -- already handled above in @collectable@
               CDealloc _ -> error "insertDeallocs: CDealloc found")
          ([], mempty) cmds
 
@@ -67,58 +68,61 @@ compilePAcc' :: AVarEnv aenv -> TupANames t -> A.PreOpenAcc A.OpenAcc aenv t ->
 compilePAcc' aenv destnames = \case
     A.Alet lhs rhs body -> do
         (names, aenv') <- genVarsAEnv lhs aenv
-        let sts1 = [C.SDecl t n Nothing | TypedAName t n <- itupList names]
-        let cmds1 = [CChunk [] sts1 []]
+        let sts1sh = [C.SDecl t n Nothing | TypedName t n <- fst (tupanamesList names)]
+            sts1arr = [C.SDecl t n Nothing | TypedAName t n <- snd (tupanamesList names)]
+        let cmds1 = [CChunk [] (sts1sh ++ sts1arr) []]
         cmds2 <- compileAcc' aenv names rhs
         cmds3 <- compileAcc' aenv' destnames body
         return (cmds1 ++ cmds2 ++ cmds3)
 
-    A.Avar (Var _ idx) ->
-        return (Right ([], ITupSingle (C.EVar (aveprj aenv idx))))
-
-    A.Apair a b -> do
-        res1 <- compileAcc' aenv a
-        res2 <- compileAcc' aenv b
-        return (Left (\case
-            ITupPair n1 n2 -> toStoring res1 n1 ++ toStoring res2 n2
-            ITupIgnore -> []
-            ITupSingle _ -> error "wat"))
+    A.Avar (Var _ idx)
+      | ANArray destshnames destarrnames <- destnames -> do
+          let (shnames, arrnames) = aveprj aenv idx
+              sts = [C.SAsg destn (C.EVar srcn)
+                    | (TypedName _ destn, TypedName _ srcn) <- zip (shnamesList destshnames) (shnamesList shnames)]
+                    ++
+                    [C.SAsg destn (C.EVar srcn)
+                    | (destn, srcn) <- zipDestSrcNames destarrnames arrnames]
+              usedA = map (\(TypedAName _ n) -> n) (itupList arrnames)
+          return [CChunk [] sts usedA]
+
+    A.Apair a b
+      | ANPair destnames1 destnames2 <- destnames -> do
+          res1 <- compileAcc' aenv destnames1 a
+          res2 <- compileAcc' aenv destnames2 b
+          return (res1 ++ res2)
 
     _ -> throw "Unsupported Acc constructor"
-  where
-    toStExprs :: TypeR t -> Either (ANames t -> [C.Stmt]) ([C.Stmt], Exprs t) -> SC ([C.Stmt], Exprs t)
-    toStExprs ty (Left fun) = do
-        names <- genAVars ty
-        let sts1 = fun names
-        return (sts1, itupmap (\(TypedName _ n) -> C.EVar n) names)
-    toStExprs _ (Right pair) = return pair
-
-    toStoring :: Either (Names t -> [C.Stmt]) ([C.Stmt], Exprs t) -> Names t -> [C.Stmt]
-    toStoring (Left f) = f
-    toStoring (Right (sts, exs)) = (sts ++) . flip go exs
-      where
-        go :: Names t -> Exprs t -> [C.Stmt]
-        go (ITupSingle (TypedName _ name)) (ITupSingle ex) = [C.SAsg name ex]
-        go (ITupSingle _) _ = error "wat"
-        go ITupIgnore _ = []
-        go (ITupPair ns1 ns2) (ITupPair es1 es2) = go ns1 es1 ++ go ns2 es2
-        go (ITupPair _ _) _ = error "wat"
+
+zipDestSrcNames :: ANames e -> ANames e -> [(C.Name, C.Name)]
+zipDestSrcNames ITupIgnore _ = []
+zipDestSrcNames _ ITupIgnore = error "Ignore in source names where there is none in the destination names"
+zipDestSrcNames (ITupSingle (TypedAName _ n)) (ITupSingle (TypedAName _ n')) = [(n, n')]
+zipDestSrcNames (ITupPair a b) (ITupPair a' b') = zipDestSrcNames a a' ++ zipDestSrcNames b b'
+zipDestSrcNames _ _ = error "wat"
 
 genVarsAEnv :: A.ALeftHandSide t aenv aenv' -> AVarEnv aenv -> SC (TupANames t, AVarEnv aenv')
 genVarsAEnv (LeftHandSideWildcard _) env = return (ANIgnore, env)
-genVarsAEnv (LeftHandSideSingle (ArrayR _ ty)) env = do
-    name <- genName "a"
-    ty' <- cvtType ty
-    return (ITupSingle (TypedAName ty' name), AVEPush _ name env)
+genVarsAEnv (LeftHandSideSingle (ArrayR sht ty)) env = do
+    shnames <- genShNames sht
+    names <- genAVars ty
+    return (ANArray shnames names, AVEPush shnames names env)
 genVarsAEnv (LeftHandSidePair lhs1 lhs2) env = do
     (n1, env1) <- genVarsAEnv lhs1 env
     (n2, env2) <- genVarsAEnv lhs2 env1
-    return (ITupPair n1 n2, env2)
+    return (ANPair n1 n2, env2)
 
 genAVars :: TypeR t -> SC (ANames t)
 genAVars TupRunit = return ITupIgnore
 genAVars (TupRsingle ty) = genAVar ty
 genAVars (TupRpair t1 t2) = ITupPair <$> genAVars t1 <*> genAVars t2
 
+genShNames :: ShapeR sh -> SC (ShNames sh)
+genShNames ShapeRz = return ShZ
+genShNames (ShapeRsnoc sht) = do
+    name <- genName "n"
+    names <- genShNames sht
+    return (ShS name names)
+
 genAVar :: ScalarType t -> SC (ANames t)
 genAVar ty = ITupSingle <$> (TypedAName <$> cvtType ty <*> genName "a")
diff --git a/SC/Defs.hs b/SC/Defs.hs
index 685d408..bb8e03f 100644
--- a/SC/Defs.hs
+++ b/SC/Defs.hs
@@ -59,7 +59,7 @@ type ANames = ITup TypedAName
 
 type Exprs = ITup C.Expr
 
--- Type is a pointer type
+-- Type is the pointer type of the type that this name is supposed to be according to the type index.
 data TypedAName = TypedAName C.Type Name
 
 data TupANames t where