Initial

1 files changed, 116 insertions, 0 deletions

diff --git a/SC/Defs.hs b/SC/Defs.hs
new file mode 100644
index 0000000..685d408
--- /dev/null
+++ b/SC/Defs.hs
@@ -0,0 +1,116 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+module SC.Defs where
+
+import Data.Array.Accelerate.AST.Idx
+import Data.Array.Accelerate.Representation.Array
+import Data.Array.Accelerate.Type
+
+import qualified Language.C as C
+import Language.C (Name(..))
+import SC.Monad
+
+
+-- ENVIRONMENTS
+-- ------------
+
+data AVarEnv env where
+    AVENil :: AVarEnv ()
+    AVEPush :: ShNames sh -> ANames t -> AVarEnv env -> AVarEnv (env, Array sh t)
+
+aveprj :: AVarEnv env -> Idx env (Array sh t) -> (ShNames sh, ANames t)
+aveprj (AVEPush shn n _) ZeroIdx = (shn, n)
+aveprj (AVEPush _ _ aenv) (SuccIdx idx) = aveprj aenv idx
+
+data VarEnv env where
+    VENil :: VarEnv ()
+    VEPush :: Name -> VarEnv env -> VarEnv (env, t)
+
+veprj :: VarEnv env -> Idx env t -> Name
+veprj (VEPush n _) ZeroIdx = n
+veprj (VEPush _ env) (SuccIdx idx) = veprj env idx
+
+
+-- IGNORE TUPLES
+-- -------------
+
+data ITup s t where
+    ITupPair :: ITup s a -> ITup s b -> ITup s (a, b)
+    ITupSingle :: s -> ITup s a
+    ITupIgnore :: ITup s a
+
+itupfold :: (forall a. f a) -> (forall a. s -> f a) -> (forall a b. f a -> f b -> f (a, b))
+         -> ITup s t -> f t
+itupfold z _ _ ITupIgnore = z
+itupfold _ f _ (ITupSingle x) = f x
+itupfold z f g (ITupPair a b) = g (itupfold z f g a) (itupfold z f g b)
+
+itupmap :: (s1 -> s2) -> ITup s1 t -> ITup s2 t
+itupmap f = itupfold ITupIgnore (ITupSingle . f) ITupPair
+
+itupList :: ITup s t -> [s]
+itupList (ITupPair t1 t2) = itupList t1 ++ itupList t2
+itupList (ITupSingle x) = [x]
+itupList ITupIgnore = []
+
+data TypedName = TypedName C.Type Name
+type Names = ITup TypedName
+type ANames = ITup TypedAName
+
+type Exprs = ITup C.Expr
+
+-- Type is a pointer type
+data TypedAName = TypedAName C.Type Name
+
+data TupANames t where
+    ANPair :: TupANames a -> TupANames b -> TupANames (a, b)
+    ANArray :: ShNames sh -> ITup TypedAName t -> TupANames (Array sh t)
+    ANIgnore :: TupANames a
+
+-- Shape names and data array names
+tupanamesList :: TupANames t -> ([TypedName], [TypedAName])
+tupanamesList (ANPair a b) =
+    let (shn1, an1) = tupanamesList a
+        (shn2, an2) = tupanamesList b
+    in (shn1 ++ shn2, an1 ++ an2)
+tupanamesList (ANArray shn ns) = (shnamesList shn, itupList ns)
+tupanamesList ANIgnore = ([], [])
+
+data ShNames sh where
+    ShZ :: ShNames ()
+    ShS :: Name -> ShNames sh -> ShNames (sh, Int)
+
+shnamesList :: ShNames sh -> [TypedName]
+shnamesList ShZ = []
+shnamesList (ShS n shns) = TypedName (C.TInt C.B64) n : shnamesList shns
+
+
+-- GENERATING VARIABLE NAMES
+-- -------------------------
+
+genName :: String -> SC Name
+genName prefix = Name . (prefix ++) . show <$> genId
+
+
+-- TYPE CONVERSION
+-- ---------------
+
+cvtType :: ScalarType t -> SC C.Type
+cvtType (SingleScalarType (NumSingleType (IntegralNumType it))) = return (cvtIT it)
+  where cvtIT :: IntegralType t -> C.Type
+        cvtIT TypeInt = C.TInt C.B64
+        cvtIT TypeInt8 = C.TInt C.B8
+        cvtIT TypeInt16 = C.TInt C.B16
+        cvtIT TypeInt32 = C.TInt C.B32
+        cvtIT TypeInt64 = C.TInt C.B64
+        cvtIT TypeWord = C.TUInt C.B64
+        cvtIT TypeWord8 = C.TUInt C.B8
+        cvtIT TypeWord16 = C.TUInt C.B16
+        cvtIT TypeWord32 = C.TUInt C.B32
+        cvtIT TypeWord64 = C.TUInt C.B64
+cvtType (SingleScalarType (NumSingleType (FloatingNumType ft))) = cvtFT ft
+  where cvtFT :: FloatingType t -> SC C.Type
+        cvtFT TypeHalf = throw "Half floats not supported"
+        cvtFT TypeFloat = return C.TFloat
+        cvtFT TypeDouble = return C.TDouble
+cvtType VectorScalarType{} = throw "Vector types not supported"