WIP: working on tuple conversion. (re: issue #10)

backend-kit/Data/Array/Accelerate/BackendKit/CompilerPipeline.hs

@@ -175,12 +175,13 @@ typecheckPass dimMode prog =
 -- | Pass composition:
 runPass :: Out a => String -> (t -> a) -> t -> a
 runPass msg pass input =
+  let output = pass input in
   if dbg>=4 then
-    trace ("\n" ++ msg ++ ", output was:\n"++
-           "================================================================================\n"
-           ++ show (doc x)) x
-  else x
- where x = pass input              
+    input `seq` 
+    (trace ("\n" ++ msg ++ ", output was:\n"++
+           "================================================================================\n")
+     (trace (show (doc output)) output))
+  else output
 
 -- An [optional] optimization pass:
 runOptPass :: Out a => String -> (t -> a) -> (t -> a) -> t -> a

backend-kit/Data/Array/Accelerate/BackendKit/ConsoleTester.hs

@@ -80,7 +80,7 @@ makeMain BackendTestConf{backend,sbackend,knownTests,extraTests,frontEndFusion}
                        optionsDescription 
  if Help `elem` opts || errs /= [] then error help2
   else do
-   let passthru = nonopts ++ unrecog
+   let passthru = unrecog ++ nonopts 
    -- let passthru = args
    putStrLn$ "  [Note: passing through options to test-framework]: "++unwords passthru
    withArgs passthru $ do 

backend-kit/Data/Array/Accelerate/BackendKit/Phase1/ToAccClone.hs

@@ -9,10 +9,6 @@
 --   * Add type info to some language forms... 
 --   * Convert boundary
 
--- Toggle this to try to match the source tuple format rather than the
--- Snoc-list accelerate internal format.
-#define SURFACE_TUPLES
-
 -- | PHASE1 :  Accelerate -> SimpleAcc
 --
 -- This module provides a function to convert from Accelerate's
@@ -61,8 +57,16 @@ accToAccClone :: Sug.Arrays a => AST.Acc a -> TAExp
 accToAccClone = runEnvM . convertAcc 
 
 -- | Must take a closed expression.
-expToExpClone :: forall env aenv ans . OpenExp env aenv ans -> T.Exp
-expToExpClone = runEnvM . convertExp
+-- expToExpClone :: forall env aenv ans . OpenExp env aenv ans -> T.Exp
+expToExpClone :: AST.Exp () ans -> T.Exp
+expToExpClone x = runEnvM (convertExp x)
+
+
+
+-- type OpenExp = PreOpenExp OpenAcc
+-- type Exp = OpenExp () = PreOpenExp OpenAcc () 
+-- data PreOpenExp (acc :: * -> * -> *) env aenv t where
+
 
 type TAExp = T.AExp S.Type
 
@@ -321,6 +325,9 @@ convertBoundary = error "convertBoundary: implement me" -- FIXME TODO
 -- Takes a closed expression
 convertExp :: forall env aenv ans . OpenExp env aenv ans -> EnvM T.Exp
 convertExp e = 
+  -- (\x -> do x' <- x
+  --           trace ("CONVERTING EXP "++show e ++ " -> "++show x') 
+  --             (return x')) $ 
   case e of 
     Let exp1 exp2 -> 
       do e1     <- convertExp exp1
@@ -456,24 +463,15 @@ convertExp e =
 
 -- | Convert a tuple expression to our simpler Tuple representation (containing a list):
 --   ASSUMES that the target expression is in fact a tuple construct.
-#ifdef SURFACE_TUPLES                     
 convertTuple :: Tuple (PreOpenExp OpenAcc env aenv) t' -> EnvM T.Exp
 convertTuple NilTup = return$ T.ETuple []
 convertTuple (SnocTup tup e) = 
-    do e' <- convertExp e
+    -- trace ("CONVERTING TUPLE "++show (e))$ 
+    do e'   <- convertExp e
        tup' <- convertTuple tup
        case tup' of 
          T.ETuple ls -> return$ T.ETuple$ ls ++ [e'] -- Snoc!
          se -> error$ "convertTuple: expected a tuple expression, received:\n  "++ show se
-#else
--- Option 2: use a tupling that preservers the Acc-internal snoc-tree representation:
-convertTuple :: Tuple (PreOpenExp OpenAcc env aenv) t' -> EnvM T.Exp
-convertTuple NilTup = return$ T.ETuple []
-convertTuple (SnocTup tup e) = 
-    do e' <- convertExp e
-       tup' <- convertTuple tup
-       return (T.ETuple [tup', e'])
-#endif
 
 
 tupleNumLeaves :: S.Type -> Int
@@ -539,9 +537,6 @@ convertType origty =
 --   with no extra fuss.
 convertArrayType :: forall arrs . Sug.ArraysR arrs -> S.Type
 convertArrayType origty = 
-#ifndef SURFACE_TUPLES
-     removeOuterEndcap $ 
-#endif
      tupleTy $ flattenTupTy $ loop origty
   where 
     loop :: forall ar . Sug.ArraysR ar -> S.Type
@@ -556,23 +551,12 @@ convertArrayType origty =
 
        Sug.ArraysRpair t0 t1 -> S.TTuple [loop t0, loop t1]
 
--- Flatten the snoc-list representation of tuples, at the array as well as scalar level
+-- | Flatten the snoc-list representation of tuples, at the array as well as scalar level
 flattenTupTy :: S.Type -> [S.Type]
-flattenTupTy ty = 
-#ifdef SURFACE_TUPLES
-  -- reverse $ 
-  loop ty 
+flattenTupTy ty = loop ty 
  where 
   -- When using the surface representation we reverse (cons instead of snoc):
   mkTup = S.TTuple -- . reverse
-#else
-  -- DISABLE flattening  
-  case ty of
-    S.TTuple ls -> ls
-    oth         -> [oth]
- where 
-  mkTup = S.TTuple 
-#endif
   isClosed (S.TTuple [S.TTuple [],_r]) = True
   isClosed (S.TTuple [l,_r]) = isClosed l       
   isClosed _                = False
@@ -585,6 +569,7 @@ flattenTupTy ty =
   loop oth           = [oth]
 
 
+-- | Constructor that refuses to make singleton tuple types.
 tupleTy [ty] = ty
 tupleTy ls = S.TTuple ls
 
@@ -595,18 +580,33 @@ tupleTy ls = S.TTuple ls
 
 -- convertConst :: Sug.Elt t => Sug.EltRepr t -> S.Const
 convertConst :: TupleType a -> a -> S.Const
-convertConst ty c = 
---  trace ("Converting tuple const: "++show ty) $
+convertConst ty0 c0 = 
+  (\x -> x `seq` trace ("Converting tuple const: "++show ty0++" -> "++show x) x) $
+  branch ty0 c0
+ where
+ -- Follow the leftmost side 
+ spine :: TupleType a -> a -> [S.Const]
+ spine ty c = 
+  (\x -> x `seq` trace (" *: Spine "++show ty++" -> "++show x) x) $
+  case ty of 
+    UnitTuple -> []
+    PairTuple ty1 ty0 -> let (c1,c0) = c 
+                             c0' = branch ty0 c0
+                         in c0' : spine ty1 c1
+    SingleTuple scalar -> error $ "convertConst: bad tuple, should not see a scalar on the leftmost path."
+
+ branch :: TupleType a -> a -> S.Const
+ branch ty c = 
+  (\x -> x `seq` trace (" *: Branch "++show ty++" -> "++show x) x) $
   case ty of 
     UnitTuple -> S.Tup []
+    -- This begins a new tuple:
     PairTuple ty1 ty0 -> let (c1,c0) = c 
-                             c0' = convertConst ty0 c0
+                             c0' = branch ty0 c0
                          in 
-                         case convertConst ty1 c1 of
-                           S.Tup [] -> c0' 
-                           S.Tup ls -> S.Tup (c0' : ls)
-                           singl -> S.Tup [c0', singl]
---                           oth -> error$ "mal constructed tuple on RHS of PairTuple: "++ show oth
+                         case spine ty1 c1 of
+                           [] -> c0' 
+                           ls -> S.Tup (c0' : ls)
     SingleTuple scalar -> 
       case scalar of 
         NumScalarType (IntegralNumType typ) -> 
@@ -953,8 +953,8 @@ packArray orig@(S.AccArray dims origPayloads) =
 --   of an Acc computation, i.e. a real Accelerate array.
 repackAcc :: forall a . Sug.Arrays a => Sug.Acc a -> [S.AccArray] -> a
 repackAcc dummy simpls = 
-      -- maybtrace (" [repackAcc] ... "++show rep++", given "++show (length simpls)++" arrs:\n"
-      --         ++ unlines(L.map (("   "++) . show) simpls)) $ 
+      maybtrace (" [repackAcc] ... "++show rep++", given "++show (length simpls)++" arrs:\n"
+              ++ unlines(L.map (("   "++) . show) simpls)) $ 
       Sug.toArr converted
   where
    converted :: Sug.ArrRepr a = fst$ cvt rep (reverse simpls)

backend-kit/Data/Array/Accelerate/BackendKit/Phase1/VerifySimpleAcc.hs

@@ -56,7 +56,7 @@ verifySimpleAcc cfg@(VerifierConfig{dimMode}) prog@Prog{progBinds, progResults,
     topBinds = []
 
 
-verifyUnique = error "verifyUnique"
+-- verifyUnique = error "verifyUnique"
 
 mismatchErr :: (Show a, Show a1) => String -> a -> a1 -> String
 mismatchErr msg got expected = msg++" does not match expected. "++
@@ -267,6 +267,7 @@ doE _ _ = Nothing
 
 -------------------------------------------------------------------------------
 
+-- Concatenate error messages:
 or :: Maybe ErrorMessage -> Maybe ErrorMessage -> Maybe ErrorMessage 
 or (Just x) (Just y) = Just (x++"\n"++y)
 or (Just x) Nothing = Just x

backend-kit/Data/Array/Accelerate/BackendKit/SimpleArray.hs

@@ -498,12 +498,12 @@ tuple ls  = Tup ls
 
 -- | Take a list of arrays of equal shape and concat them into a single AccArray.  
 concatAccArrays :: [S.AccArray] -> S.AccArray
-concatAccArrays [] = error "zipAccArrays: Cannot zip an empty list of AccArrays (don't know dimension)"
+concatAccArrays [] = error "concatAccArrays: Cannot zip an empty list of AccArrays (don't know dimension)"
 concatAccArrays origls = 
   if not (allSame lens)
-  then error$"zipAccArrays: mismatch in lengths: "++show lens
+  then error$"concatAccArrays: mismatch in lengths: "++show lens
   else if not (allSame dims)
-       then error$"zipAccArrays: mismatch in dims: "++show dims
+       then error$"concatAccArrays: mismatch in dims: "++show dims
        else S.AccArray (head dims) payls
  where 
   lens = L.map payloadLength payls

backend-kit/Data/Array/Accelerate/BackendKit/Tests.hs

@@ -26,14 +26,18 @@ module Data.Array.Accelerate.BackendKit.Tests
     p10, p10b, p10c, p10d, p10e, p10f, p10g, p10h, p10i, 
     p11, p11b, p11c,
     p12, p12b, p12c, p12d, p12e,
-    p13, p13b, p13c, p13d, p13e, p13f, p14, p14b, p14c, p14d, p14e, 
+    p13, p13b, p13c, p13d, p13e, p13f, p13g, p13g2, p13h, p13i, p13j, p13k, 
+    p14, p14b, p14c, p14d, p14e, 
     p16a, p16b, p16c, p16d, p16e, p17a, p17b,
     p18a, p18b, p18c, p18d, p18e, p18f,
 
     p20a, p20b, p20c, 
 
     -- * Reexports to make life easier:
-    doc, convertToSimpleProg
+    doc, convertToSimpleProg,
+
+    -- Temp:
+    p2b_slc, p2b_test
    )
    where 
 
@@ -140,6 +144,7 @@ otherProgs =
   -- go "p12" p12,  -- [2014.02.20] Temporarily disabled.  This one is nondeterministic (issue #8).  Returning to it later.
   go "p12b" p12b, go "p12c" p12c, go "p12d" p12d, go "p12e" p12e, 
   go "p13" p13, go "p13b" p13b, go "p13c" p13c, go "p13d" p13d, go "p13e" p13e, go "p13f" p13f,
+  go "p13g" p13g, go "p13g2" p13g2, go "p13h" p13h, go "p13i" p13i, go "p13j" p13j, go "p13k" p13k,
   go "p14" p14, go "p14b" p14b, 
   go "p14c" p14c, go "p14d" p14d, go "p14e" p14e,
 
@@ -299,13 +304,22 @@ p2aa = let xs = replicate (constant (Z :. (4::Int) :. (3::Int))) (unit 40)
 p2a :: Acc (Scalar Word)
 p2a = unit 40
 
+-- This is an example of the weird encoding we get where slice expressions with All's
+-- on the outer most dimensions don't have a representation (unit) of those All's.
 p2b :: Acc (Array DIM2 Int)
 p2b = let arr = generate (constant (Z :. (5::Int))) unindex1
 --      in replicate (constant$ Z :. (4::Int) :. All) arr
       in replicate (constant$ Z :. All :. (4::Int)) arr
           -- 1st generates: Array (Z :. 4 :. 5) [0,1,2,3,4,0,1,2,3,4,0,1,2,3,4,0,1,2,3,4]
           -- 2nd generates: Array (Z :. 5 :. 4) [0,0,0,0,1,1,1,1,2,2,2,2,3,3,3,3,4,4,4,4]
 
+p2b_slc = (constant$ Z :. All :. (4::Int))
+
+
+p2b_test :: Acc (Array DIM2 Int)
+p2b_test = let arr = generate (constant (Z :. (5::Int))) unindex1
+      in replicate p2b_slc arr
+
 -- A replicate-of-replicate with a 3D result:
 p2bb :: Acc (Array DIM3 Int)
 -- Array (Z :. 5 :. 3 :. 4) 
@@ -690,6 +704,24 @@ p13f = unit $
 --  Why is it not (((), (((), Int8), Int16)), (((), Int32), Int64)) ??
 --  Why does it appear to follow a different convention for tuples of tuples?
 
+p13g :: Acc (Scalar Z)
+p13g = unit $ constant Z
+
+p13g2 :: Acc (Vector Z)
+p13g2 = generate (constant (Z :. (10::Int))) (\_ -> constant Z)
+
+p13h :: Acc (Scalar (Z :. Int))
+p13h = unit $ constant (Z :. 3)
+
+p13i :: Acc (Scalar (Z :. Int :. Int))
+p13i = unit $ constant (Z :. 3 :. 4)
+
+p13j :: Acc (Scalar (Z :. All :. Int))
+p13j = unit $ constant (Z :. All :. 4)
+
+p13k :: Acc (Scalar (Z :. Int :. All))
+p13k = unit $ constant (Z :. 3 :. All)
+
 --------------------------------------------------------------------------------
 -- And test projection as well:
 

backend-kit/accelerate-backend-kit.cabal

@@ -41,7 +41,7 @@ Library
                      Data.Array.Accelerate.BackendKit.Phase1.RemoveArrayTuple
                      Data.Array.Accelerate.BackendKit.Phase1.StaticTuples
                      Data.Array.Accelerate.BackendKit.Phase1.ToAccClone
-                     Data.Array.Accelerate.BackendKit.Phase1.VerifySimpleAcc                     
+                     Data.Array.Accelerate.BackendKit.Phase1.VerifySimpleAcc
                      Data.Array.Accelerate.BackendKit.Phase2.DeadCode
                      Data.Array.Accelerate.BackendKit.Phase2.DesugarUnit
                      Data.Array.Accelerate.BackendKit.Phase2.DesugToBackperm