diff options
| -rw-r--r-- | Data/Array/Accelerate/C.hs | 76 | ||||
| -rw-r--r-- | Data/Array/Accelerate/Trafo/UnDelayed.hs | 59 | ||||
| -rw-r--r-- | Language/C.hs | 3 | ||||
| -rw-r--r-- | Language/C/Print.hs | 4 | ||||
| -rw-r--r-- | SC/Acc.hs | 38 | ||||
| -rw-r--r-- | SC/Afun.hs | 141 | ||||
| -rw-r--r-- | SC/Defs.hs | 33 | ||||
| -rw-r--r-- | SC/Exp.hs | 62 | ||||
| -rw-r--r-- | SC/Prelude.hs | 8 | ||||
| -rw-r--r-- | accelerate-sc.cabal | 7 | ||||
| -rw-r--r-- | prelude.c | 7 |
11 files changed, 395 insertions, 43 deletions
diff --git a/Data/Array/Accelerate/C.hs b/Data/Array/Accelerate/C.hs new file mode 100644 index 0000000..faa06f1 --- /dev/null +++ b/Data/Array/Accelerate/C.hs @@ -0,0 +1,76 @@ +{-| +Module : Data.Array.Accelerate.C +Description : Sequential C backend for Accelerate +Copyright : (c) Tom Smeding, 2021 +License : MIT +Maintainer : x+accelerate@tomsmeding.com +Stability : experimental +Portability : non-portable (GHC extensions) + +This is a sequential C backend to Accelerate. + +Arrays are flattened in the C code: a two-dimensional array with elements of +type @Float@ is encoded as a row-major single-dimensional array of type +@float*@ in C. The indexing is the same as for the @linearIndex@ function from +Accelerate. + +Because of the choices made in representing arrays as arguments to the +generated C functions, using this backend may require a (basic) understanding +of how Accelerate internally represents arrays (i.e. the so-called +/representation types/). However, this only really becomes relevant if you use +self-defined data types or sum types like @Maybe@, since otherwise it should be +intuitive enough for casual use. These representation types show up in the +precise form of the argument and output variable descriptors ('CArrTupNames') +returned by 'translateAcc', and they influence the ordering of the arguments to the +C functions. +-} +module Data.Array.Accelerate.C ( + translateAcc, + CArrTupNames(..), CShNames(..), CArrNames(..), + C.Name(..), C.Type(..), C.Bits(..), +) where + +import qualified Data.Array.Accelerate.Smart as Smart +import qualified Data.Array.Accelerate.Sugar.Array as A +import qualified Data.Array.Accelerate.Trafo as A + +import Data.Array.Accelerate.Trafo.UnDelayed +import qualified Language.C as C +import Language.C.Print (printProgram) +import SC.Afun +import SC.Prelude +import SC.Monad + + +-- | The function passed should have exactly one argument (that may consist of +-- multiple arrays in a tuple, of course). The string argument determines the +-- name of the top-level generated C function. +-- +-- The result consists of: +-- +-- 1. C source code (including required prelude) defining, ultimately, a C +-- function that implements the top-level Accelerate array function. +-- 2. The variable names corresponding to the components of the argument of the +-- top-level function. +-- 3. The variable names corresponding to the components of the result of the +-- top-level function. These are out-arguments (i.e. pointer arguments) to +-- that function. +-- +-- For an example of how the produced function looks and how the variable name +-- containers describe its arguments, see the documentation of 'CArrTupNames'. +-- +-- Note that the variable name descriptors refer to the /representation types/ +-- of the input and output of the array function. This essentially means that +-- the type has been converted to a form using only pairs and arrays. (This is +-- the internal representation of data types in Accelerate.) +translateAcc :: (A.Arrays a, A.Arrays b) + => String + -> (Smart.Acc a -> Smart.Acc b) + -> Either String (String, CArrTupNames (A.ArraysR a), CArrTupNames (A.ArraysR b)) +translateAcc procname afun = do + let ast = unDelayedAfun (A.convertAfun afun) + (auxdefs, fundef, argnames, outnames) <- evalSC (compileAfun1 (C.Name procname) ast) + let program = C.Program (auxdefs ++ [fundef]) + return (prelude ++ "\n" ++ printProgram program 0 "" + ,argnames + ,outnames) diff --git a/Data/Array/Accelerate/Trafo/UnDelayed.hs b/Data/Array/Accelerate/Trafo/UnDelayed.hs new file mode 100644 index 0000000..8553dfa --- /dev/null +++ b/Data/Array/Accelerate/Trafo/UnDelayed.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +module Data.Array.Accelerate.Trafo.UnDelayed ( + unDelayed, unDelayedAfun +) where + +import Data.Array.Accelerate.AST +import Data.Array.Accelerate.Trafo.Delayed + + +-- | Convert from a delayed Acc representation back to the pre-fusion, internal +-- Acc representation. This forgets information about whether nodes are +-- manifest or not. +unDelayed :: DelayedOpenAcc aenv a -> OpenAcc aenv a +unDelayed (Manifest acc) = OpenAcc (unDelayed `through` acc) +unDelayed (Delayed repr shexp fun _) = unDelayed (Manifest (Generate repr shexp fun)) + +unDelayedAfun :: DelayedOpenAfun aenv a -> OpenAfun aenv a +unDelayedAfun (Alam lhs fun) = Alam lhs (unDelayedAfun fun) +unDelayedAfun (Abody a) = Abody (unDelayed a) + +through :: (forall aenv' t. f aenv' t -> g aenv' t) + -> PreOpenAcc f aenv a + -> PreOpenAcc g aenv a +through f = \case + Alet lhs rhs body -> Alet lhs (f rhs) (f body) + Avar var -> Avar var + Apair a1 a2 -> Apair (f a1) (f a2) + Anil -> Anil + Apply ty fun a -> Apply ty (f `throughAF` fun) (f a) + Aforeign ty asm fun a -> Aforeign ty asm (f `throughAF` fun) (f a) + Acond e a1 a2 -> Acond e (f a1) (f a2) + Awhile fun1 fun2 a -> Awhile (f `throughAF` fun1) (f `throughAF` fun2) (f a) + Use ty arr -> Use ty arr + Unit ety e -> Unit ety e + Reshape sht e a -> Reshape sht e (f a) + Generate ty e efun -> Generate ty e efun + Transform ty e efun1 efun2 a -> Transform ty e efun1 efun2 (f a) + Replicate slix e a -> Replicate slix e (f a) + Slice slix a e -> Slice slix (f a) e + Map ty fun a -> Map ty fun (f a) + ZipWith ty fun a1 a2 -> ZipWith ty fun (f a1) (f a2) + Fold efun me a -> Fold efun me (f a) + FoldSeg ety efun me a1 a2 -> FoldSeg ety efun me (f a1) (f a2) + Scan dir efun me a -> Scan dir efun me (f a) + Scan' dir efun e a -> Scan' dir efun e (f a) + Permute efun1 a1 efun2 a2 -> Permute efun1 (f a1) efun2 (f a2) + Backpermute sht e efun a -> Backpermute sht e efun (f a) + Stencil stty ety efun bnd a -> Stencil stty ety efun bnd (f a) + Stencil2 stty1 stty2 ety efun bnd1 a1 bnd2 a2 -> + Stencil2 stty1 stty2 ety efun bnd1 (f a1) bnd2 (f a2) + +throughAF :: (forall aenv' t. f aenv' t -> g aenv' t) + -> PreOpenAfun f aenv a + -> PreOpenAfun g aenv a +throughAF f = \case + Abody a -> Abody (f a) + Alam lhs fun -> Alam lhs (f `throughAF` fun) diff --git a/Language/C.hs b/Language/C.hs index 35cf432..6a3256f 100644 --- a/Language/C.hs +++ b/Language/C.hs @@ -9,6 +9,7 @@ data FunDef | ProcDef Name [(Type, Name)] [Stmt] deriving (Show, Eq) +-- | Some C types. data Type = TInt Bits | TUInt Bits @@ -17,9 +18,11 @@ data Type | TPtr Type deriving (Show, Eq) +-- | The number of bits in a C integral type. data Bits = B8 | B16 | B32 | B64 deriving (Show, Eq) +-- | A C variable or function name. newtype Name = Name String deriving (Show, Eq, Ord) diff --git a/Language/C/Print.hs b/Language/C/Print.hs index e075b0e..cc511b2 100644 --- a/Language/C/Print.hs +++ b/Language/C/Print.hs @@ -20,12 +20,12 @@ printFunDef (FunDef rt n as (StExpr ss rete)) = % intercalates ", " [printType t % printString " " % printName an | (t, an) <- as] % printString ") {\n " % addIndent 2 (intercalates "\n" (map printStmt ss)) - % printString "\n return (" % printExpr rete % printString ");\n}" + % printString "\n return (" % printExpr rete % printString ");\n}\n" printFunDef (ProcDef n as ss) = printString "void " % printName n % printString "(" % intercalates ", " [printType t % printString " " % printName an | (t, an) <- as] - % printString ") " % printBlock ss + % printString ") " % printBlock ss % printString "\n" printName :: Name -> PrintS printName (Name s) = printString s @@ -100,7 +100,8 @@ compilePAcc' aenv destnames = \case CompiledFun funFD funArgbuilder usedAfun <- compileFun aenv fun tempnames <- genVars restype loops <- enumShapeNested destshnames $ \idxnames linidxexpr -> concat - [[C.SCall (C.fundefName funFD) + [[C.SDecl t n Nothing | TypedName t n <- itupList tempnames] + ,[C.SCall (C.fundefName funFD) (funArgbuilder (itupEvars (fromShNames idxnames)) tempnames)] ,[C.SStore arrname linidxexpr (C.EVar tempname) | (arrname, tempname) <- zipDestSrcNamesAE destarrnames tempnames]] @@ -108,42 +109,46 @@ compilePAcc' aenv destnames = \case [[CChunk [sheFD] [C.SCall (C.fundefName sheFD) (sheArgbuilder ITupIgnore (fromShNames destshnames))] - (map (\(TypedAName _ n) -> n) usedAshe)] + (concatMap (\(SomeArray _ ans) -> + map (\(TypedAName _ n) -> n) (itupList ans)) + usedAshe)] ,[CAlloc [] eltty n (C.StExpr [] (computeSize destshnames)) | TypedAName arrty n <- itupList destarrnames , let C.TPtr eltty = arrty] ,[CChunk [funFD] loops - (map (\(TypedAName _ n) -> n) (itupList destarrnames ++ usedAfun))]] + (map (\(TypedAName _ n) -> n) + (itupList destarrnames + ++ concatMap (\(SomeArray _ ans) -> itupList ans) usedAfun))]] _ -> throw "Unsupported Acc constructor" -- | Returns an expression of type int64_t computeSize :: ShNames sh -> C.Expr computeSize ShZ = C.ELit "1LL" -computeSize (ShS n ShZ) = C.EVar n -computeSize (ShS n ns) = C.EOp (C.EVar n) "*" (computeSize ns) +computeSize (ShS ShZ n) = C.EVar n +computeSize (ShS ns n) = C.EOp (computeSize ns) "*" (C.EVar n) -- | Given size variables and index variables, returns an expression of type int64_t linearIndexExpr :: ShNames sh -> ShNames sh -> C.Expr linearIndexExpr ShZ ShZ = C.ELit "1LL" -linearIndexExpr (ShS _ ShZ) (ShS i ShZ) = C.EVar i -linearIndexExpr (ShS n ns) (ShS i is) = +linearIndexExpr (ShS ShZ _) (ShS ShZ i) = C.EVar i +linearIndexExpr (ShS ns n) (ShS is i) = C.EOp (C.EOp (linearIndexExpr ns is) "*" (C.EVar n)) "+" (C.EVar i) -zipDestSrcNames :: ITup C.Name e -> ITup C.Name e -> [(C.Name, C.Name)] +zipDestSrcNames :: ITup C.Name t -> ITup C.Name t -> [(C.Name, C.Name)] zipDestSrcNames ITupIgnore _ = [] zipDestSrcNames _ ITupIgnore = error "Ignore in source names but not in destination names" zipDestSrcNames (ITupSingle n) (ITupSingle n') = [(n, n')] zipDestSrcNames (ITupPair a b) (ITupPair a' b') = zipDestSrcNames a a' ++ zipDestSrcNames b b' zipDestSrcNames _ _ = error "wat" -zipDestSrcNamesAA :: ANames e -> ANames e -> [(C.Name, C.Name)] +zipDestSrcNamesAA :: ANames t -> ANames t -> [(C.Name, C.Name)] zipDestSrcNamesAA ns1 ns2 = zipDestSrcNames (itupmap (\(TypedAName _ n) -> n) ns1) (itupmap (\(TypedAName _ n) -> n) ns2) -zipDestSrcNamesAE :: ANames e -> Names e -> [(C.Name, C.Name)] +zipDestSrcNamesAE :: ANames t -> Names t -> [(C.Name, C.Name)] zipDestSrcNamesAE ns1 ns2 = zipDestSrcNames (itupmap (\(TypedAName _ n) -> n) ns1) (itupmap (\(TypedName _ n) -> n) ns2) @@ -159,7 +164,7 @@ enumShapeNested sizenames fun = do idxnames <- genShNames (shNamesShape sizenames) let makeLoops :: ShNames sh -> ShNames sh -> [C.Stmt] -> [C.Stmt] makeLoops ShZ ShZ body = body - makeLoops (ShS n ns) (ShS i is) body = + makeLoops (ShS ns n) (ShS is i) body = makeLoops ns is [C.SFor (C.TInt C.B64) i (C.ELit "0") (C.EVar n) body] return (makeLoops sizenames idxnames (fun idxnames (linearIndexExpr sizenames idxnames))) @@ -174,6 +179,11 @@ genVarsAEnv (LeftHandSidePair lhs1 lhs2) env = do (n2, env2) <- genVarsAEnv lhs2 env1 return (ANPair n1 n2, env2) +genAVarsTup :: ArraysR t -> SC (TupANames t) +genAVarsTup TupRunit = return ANIgnore +genAVarsTup (TupRsingle (ArrayR sht ty)) = ANArray <$> genShNames sht <*> genAVars ty +genAVarsTup (TupRpair t1 t2) = ANPair <$> genAVarsTup t1 <*> genAVarsTup t2 + genAVars :: TypeR t -> SC (ANames t) genAVars TupRunit = return ITupIgnore genAVars (TupRsingle ty) = genAVar ty @@ -182,9 +192,9 @@ 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) + name <- genName "n" + return (ShS names name) genAVar :: ScalarType t -> SC (ANames t) -genAVar ty = ITupSingle <$> (TypedAName <$> cvtType ty <*> genName "a") +genAVar ty = ITupSingle <$> (TypedAName <$> fmap C.TPtr (cvtType ty) <*> genName "a") diff --git a/SC/Afun.hs b/SC/Afun.hs new file mode 100644 index 0000000..3379cc6 --- /dev/null +++ b/SC/Afun.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneDeriving #-} +module SC.Afun where + +import qualified Data.Array.Accelerate.AST as A +import Data.Array.Accelerate.AST.LeftHandSide +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Type + +import qualified Language.C as C +import SC.Acc +import SC.Defs +import SC.Monad + + +-- | Variable names for a tuple of arrays. Each array is represented in +-- struct-of-arrays form. For example: the type +-- @(Scalar Double, Matrix (Int, Float))@, which is internally represented as +-- @(Array () Double, Array (((), Int), Int) (Int, Float))@, would be +-- described as follows: (the variable names will differ) +-- +-- > CATNPair (CATNArray CSNNil +-- > (CANName TDouble (Name "a"))) +-- > (CATNArray (CSNSnoc (CSNSnoc CSNNil (Name "n1")) (Name "n2")) +-- > (CANPair (CANName (TInt B64) (Name "b")) +-- > (CANName TFloat (Name "c")))) +-- +-- Suppose that the Accelerate function in question has return type +-- @Vector Double@, which is to say @Array ((), Int) Double@, with description: +-- +-- > CATNArray (CSNSnoc CSNNil (Name "m")) +-- > (CANName TDouble (Name "r")) +-- +-- Then its C function definition would look as follows: +-- +-- > void function(double *a, +-- > int64_t n1, int64_t n2, int64_t *b, int64_t *c, +-- > int64_t m, double **r); +-- +-- Note that the first input array array here has zero shape arguments because +-- it is zero-dimensional. +data CArrTupNames a where + CATNPair :: CArrTupNames a -> CArrTupNames b -> CArrTupNames (a, b) + CATNArray :: CShNames sh -> CArrNames sh a -> CArrTupNames (Array sh a) + CATNNil :: CArrTupNames () +deriving instance Show (CArrTupNames a) + +-- | Names for the shape of an array. See 'CArrTupNames' for more information. +-- +-- Note that the names in this structure are are to be interpreted as variables +-- of type @int64_t@. +data CShNames sh where + CSNSnoc :: CShNames sh -> C.Name -> CShNames (sh, Int) + CSNNil :: CShNames () +deriving instance Show (CShNames a) + +-- | Names for a single array. See 'CArrTupNames' for more information. +-- +-- Note that the 'C.Type' in 'CANName' is the /element/ type of the array. +data CArrNames sh a where + CANPair :: CArrNames sh a -> CArrNames sh b -> CArrNames sh (a, b) + CANName :: C.Type -> C.Name -> CArrNames sh a + CANNil :: CArrNames sh () +deriving instance Show (CArrNames sh a) + +-- | The function passed should have exactly one argument (that may consist of +-- multiple arrays in a tuple, of course). +-- +-- The result consists of: +-- 1. An array of auxiliary function definitions that the program needs, on top +-- of the prelude. +-- 2. The function that implements the top-level Accelerate array function. +-- 3. The variable names corresponding to the components of the argument. +-- 4. The variable names corresponding to the components of the result. These +-- are double-pointer arguments to the function in (2.). +-- +-- For an example, see the documentation of 'CArrTupNames'. +compileAfun1 :: C.Name + -> A.Afun (a -> b) + -> SC ([C.FunDef], C.FunDef, CArrTupNames a, CArrTupNames b) +compileAfun1 procname (A.Alam lhs (A.Abody acc)) = do + (argnames, aenv) <- genVarsAEnv lhs AVENil + destnames <- genAVarsTup (A.arraysR acc) + let destShapeDeclSts = [C.SDecl t n Nothing + | TypedName t n <- fst (tupanamesList destnames)] + outnames <- genAVarsTup (A.arraysR acc) + (auxdefs, stmts) <- compileCommands <$> compileAcc' aenv destnames acc + return (auxdefs + ,C.ProcDef procname + (map (\case Left (TypedName t n) -> (t, n) + Right (TypedAName t n) -> (t, n)) + (tupanamesList' argnames) + ++ + map (\case Left (TypedName t n) -> (C.TPtr t, n) + Right (TypedAName t n) -> (C.TPtr t, n)) + (tupanamesList' outnames)) + (destShapeDeclSts ++ + stmts ++ + [C.SStore outn (C.ELit "0") (C.EVar destn) + | (outn, destn) <- zipOutSrcNamesT outnames destnames]) + ,makeCArrTupNames (lhsToTupR lhs) (\(C.TPtr t) -> t) argnames + ,makeCArrTupNames (A.arraysR acc) (\(C.TPtr t) -> t) outnames) + where + makeCArrTupNames :: ArraysR a -> (C.Type -> C.Type) -> TupANames a -> CArrTupNames a + makeCArrTupNames (TupRpair t1 t2) typefun (ANPair an1 an2) = + CATNPair (makeCArrTupNames t1 typefun an1) (makeCArrTupNames t2 typefun an2) + makeCArrTupNames (TupRsingle (ArrayR _ t)) typefun (ANArray shn ans) = + CATNArray (makeCShNames shn) (makeCArrNames t typefun ans) + makeCArrTupNames TupRunit _ ANIgnore = CATNNil + makeCArrTupNames _ _ ANIgnore = error "Ignore of non-nil element in generated names" + + makeCShNames :: ShNames sh -> CShNames sh + makeCShNames ShZ = CSNNil + makeCShNames (ShS ns n) = CSNSnoc (makeCShNames ns) n + + makeCArrNames :: TypeR a -> (C.Type -> C.Type) -> ANames a -> CArrNames sh a + makeCArrNames (TupRpair t1 t2) typefun (ITupPair an1 an2) = + CANPair (makeCArrNames t1 typefun an1) (makeCArrNames t2 typefun an2) + makeCArrNames (TupRsingle _) typefun (ITupSingle (TypedAName ty n)) = + CANName (typefun ty) n + makeCArrNames TupRunit _ ITupIgnore = CANNil + makeCArrNames _ _ ITupIgnore = error "Ignore of non-nil element in generated names" + makeCArrNames _ _ _ = error "Invalid GADTs" + + zipOutSrcNamesT :: TupANames t -> TupANames t -> [(C.Name, C.Name)] + zipOutSrcNamesT ANIgnore _ = [] + zipOutSrcNamesT _ ANIgnore = error "Ignore in source names but not in out names" + zipOutSrcNamesT (ANArray shn ns) (ANArray shn' ns') = + zipWith (\(TypedName _ n) (TypedName _ n') -> (n, n')) + (shnamesList shn) (shnamesList shn') + ++ zipOutSrcNames ns ns' + zipOutSrcNamesT (ANPair a b) (ANPair a' b') = zipOutSrcNamesT a a' ++ zipOutSrcNamesT b b' + + zipOutSrcNames :: ANames t -> ANames t -> [(C.Name, C.Name)] + zipOutSrcNames ITupIgnore _ = [] + zipOutSrcNames _ ITupIgnore = error "Ignore in source names but not in out names" + zipOutSrcNames (ITupPair a b) (ITupPair a' b') = zipOutSrcNames a a' ++ zipOutSrcNames b b' + zipOutSrcNames (ITupSingle (TypedAName _ n)) (ITupSingle (TypedAName _ n')) = [(n, n')] + zipOutSrcNames _ _ = error "Invalid GADTs" +compileAfun1 _ _ = throw "Not an array function with exactly one argument" @@ -1,11 +1,13 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} module SC.Defs where import Data.Array.Accelerate.AST.Idx import Data.Array.Accelerate.Representation.Array import Data.Array.Accelerate.Representation.Shape import Data.Array.Accelerate.Type +import Data.Either (lefts, rights) import qualified Language.C as C import Language.C (Name(..)) @@ -68,39 +70,44 @@ 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) + ANArray :: ShNames sh -> ANames 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 = ([], []) +tupanamesList an = let l = tupanamesList' an in (lefts l, rights l) + +tupanamesList' :: TupANames t -> [Either TypedName TypedAName] +tupanamesList' (ANPair a b) = tupanamesList' a ++ tupanamesList' b +tupanamesList' (ANArray shn ns) = + map Left (shnamesList shn) ++ map Right (itupList ns) +tupanamesList' ANIgnore = [] data ShNames sh where ShZ :: ShNames () - ShS :: Name -> ShNames sh -> ShNames (sh, Int) + ShS :: ShNames sh -> Name -> ShNames (sh, Int) +deriving instance Show (ShNames sh) shnamesList :: ShNames sh -> [TypedName] -shnamesList ShZ = [] -shnamesList (ShS n shns) = TypedName (C.TInt C.B64) n : shnamesList shns +shnamesList = reverse . go + where + go :: ShNames sh -> [TypedName] + go ShZ = [] + go (ShS shns n) = TypedName (C.TInt C.B64) n : go shns makeShNames :: ShapeR sh -> ITup TypedName sh -> ShNames sh makeShNames ShapeRz ITupIgnore = ShZ makeShNames (ShapeRsnoc sht) (ITupPair ns (ITupSingle (TypedName _ n))) = - ShS n (makeShNames sht ns) + ShS (makeShNames sht ns) n makeShNames _ _ = error "wat" fromShNames :: ShNames sh -> ITup TypedName sh fromShNames ShZ = ITupIgnore -fromShNames (ShS n ns) = ITupPair (fromShNames ns) (ITupSingle (TypedName (C.TInt C.B64) n)) +fromShNames (ShS ns n) = ITupPair (fromShNames ns) (ITupSingle (TypedName (C.TInt C.B64) n)) shNamesShape :: ShNames sh -> ShapeR sh shNamesShape ShZ = ShapeRz -shNamesShape (ShS _ ns) = ShapeRsnoc (shNamesShape ns) +shNamesShape (ShS ns _) = ShapeRsnoc (shNamesShape ns) -- GENERATING VARIABLE NAMES @@ -27,9 +27,13 @@ data CompiledFun aenv t1 t2 = -- the given names. -- The arguments will refer to array variable names found in the -- original array environment. - [TypedAName] + [SomeArray] -- ^ Arrays that the constructed arguments use from the environment +-- | The variable names corresponding to a single source-level array (before +-- SoA conversion). +data SomeArray = forall sh t. SomeArray (ShNames sh) (ANames t) + -- | The function must be single-argument. Uncurry if necessary (e.g. for zipWith). compileFun :: AVarEnv aenv -> A.Fun aenv (t1 -> t2) -> SC (CompiledFun aenv t1 t2) compileFun aenv (A.Lam lhs (A.Body body)) = do @@ -40,14 +44,19 @@ compileFun aenv (A.Lam lhs (A.Body body)) = do (usedA, res) <- compileExp' aenv env body (sts1, retexprs) <- toStExprs (A.expType body) res let sts2 = genoutstores outnames retexprs + arrayarguments = + concatMap (\(SomeArray shn ans) -> + map (\(TypedName t n) -> (t, n)) (shnamesList shn) + ++ map (\(TypedAName t n) -> (t, n)) (itupList ans)) + usedA arguments = - map (\(TypedAName t n) -> (t, n)) usedA + arrayarguments ++ map (\(TypedName t n) -> (t, n)) (itupList argnames) ++ map (\(TypedName t n) -> (t, n)) (itupList outnames) return $ CompiledFun (C.ProcDef funname arguments (sts1 ++ sts2)) (\argexprs destnames -> - map (\(TypedAName _ n) -> C.EVar n) usedA + map (C.EVar . snd) arrayarguments ++ itupList argexprs ++ map (\(TypedName _ n) -> C.EPtrTo (C.EVar n)) (itupList destnames)) usedA @@ -63,7 +72,7 @@ compileExp :: AVarEnv aenv -> A.Exp aenv t -> SC (CompiledFun aenv () t) compileExp aenv expr = compileFun aenv (A.Lam (LeftHandSideWildcard TupRunit) (A.Body expr)) compileExp' :: AVarEnv aenv -> VarEnv env -> A.OpenExp env aenv t - -> SC ([TypedAName], Either (Names t -> [C.Stmt]) ([C.Stmt], Exprs t)) + -> SC ([SomeArray], Either (Names t -> [C.Stmt]) ([C.Stmt], Exprs t)) compileExp' aenv env = \case A.Let lhs rhs body -> do (names, env') <- genVarsEnv lhs env @@ -76,6 +85,9 @@ compileExp' aenv env = \case A.Evar (Var _ idx) -> return ([], Right ([], ITupSingle (C.EVar (veprj env idx)))) + A.Nil -> + return ([], Right ([], ITupIgnore)) + A.Pair a b -> do (usedA1, res1) <- compileExp' aenv env a (usedA2, res2) <- compileExp' aenv env b @@ -84,6 +96,10 @@ compileExp' aenv env = \case ITupIgnore -> [] ITupSingle _ -> error "wat")) + A.Const ty x + | Just str <- showExpConst ty x + -> return ([], Right ([], ITupSingle (C.ELit str))) + A.PrimApp (A.PrimAdd _) e -> binary aenv env "+" e A.PrimApp (A.PrimSub _) e -> binary aenv env "-" e A.PrimApp (A.PrimMul _) e -> binary aenv env "*" e @@ -94,7 +110,7 @@ compileExp' aenv env = \case let (shnames, _) = aveprj aenv idx buildExprs :: ShNames sh -> Exprs sh buildExprs ShZ = ITupIgnore - buildExprs (ShS n names) = ITupPair (buildExprs names) (ITupSingle (C.EVar n)) + buildExprs (ShS names n) = ITupPair (buildExprs names) (ITupSingle (C.EVar n)) in return ([], Right ([], buildExprs shnames)) A.ToIndex shr she idxe -> do @@ -120,15 +136,15 @@ compileExp' aenv env = \case let sts0 = [C.SDecl (C.TInt C.B64) temp Nothing] (usedA1, sts1) <- fmap (`toStoring` ITupSingle (TypedName (C.TInt C.B64) temp)) <$> compileExp' aenv env e - let (_, anames) = aveprj aenv idx - usedA = itupList anames ++ usedA1 + let (shnames, anames) = aveprj aenv idx + usedA = SomeArray shnames anames : usedA1 return (usedA, Right (sts0 ++ sts1 ,itupmap (\(TypedAName _ name) -> C.EIndex name (C.EVar temp)) anames)) - _ -> throw "Unsupported Exp constructor" + e -> throw $ "Unsupported Exp constructor: " ++ A.showExpOp e where binary :: AVarEnv aenv -> VarEnv env -> String -> A.OpenExp env aenv (a, b) - -> SC ([TypedAName], Either (Names t -> [C.Stmt]) ([C.Stmt], Exprs t)) + -> SC ([SomeArray], Either (Names t -> [C.Stmt]) ([C.Stmt], Exprs t)) binary aenv' env' op e' = do (usedA, res) <- compileExp' aenv' env' e' (sts, ITupPair (ITupSingle e1) (ITupSingle e2)) <- @@ -138,8 +154,9 @@ compileExp' aenv env = \case toStExprs :: TypeR t -> Either (Names t -> [C.Stmt]) ([C.Stmt], Exprs t) -> SC ([C.Stmt], Exprs t) toStExprs ty (Left fun) = do names <- genVars ty - let sts1 = fun names - return (sts1, itupmap (\(TypedName _ n) -> C.EVar n) names) + let sts1 = [C.SDecl t n Nothing | TypedName t n <- itupList names] + sts2 = fun names + return (sts1 ++ sts2, 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] @@ -153,6 +170,29 @@ toStoring (Right (sts, exs)) = (sts ++) . flip go exs go (ITupPair ns1 ns2) (ITupPair es1 es2) = go ns1 es1 ++ go ns2 es2 go (ITupPair _ _) _ = error "wat" +showExpConst :: ScalarType t -> t -> Maybe String +showExpConst = \case + SingleScalarType (NumSingleType (IntegralNumType it)) -> Just . goI it + SingleScalarType (NumSingleType (FloatingNumType ft)) -> goF ft + VectorScalarType _ -> const Nothing + where + goI :: IntegralType t -> t -> String + goI TypeInt = (++ "LL") . show + goI TypeInt8 = ("(int8_t)" ++) . show + goI TypeInt16 = ("(int16_t)" ++) . show + goI TypeInt32 = show + goI TypeInt64 = (++ "LL") . show + goI TypeWord = (++ "ULL") . show + goI TypeWord8 = ("(uint8_t)" ++) . show + goI TypeWord16 = ("(uint16_t)" ++) . show + goI TypeWord32 = (++ "U") . show + goI TypeWord64 = (++ "ULL") . show + + goF :: FloatingType t -> t -> Maybe String + goF TypeHalf = const Nothing + goF TypeFloat = Just . (++ "f") . show + goF TypeDouble = Just . show + genVarsEnv :: A.ELeftHandSide t env env' -> VarEnv env -> SC (Names t, VarEnv env') genVarsEnv (LeftHandSideWildcard _) env = return (ITupIgnore, env) genVarsEnv (LeftHandSideSingle ty) env = do diff --git a/SC/Prelude.hs b/SC/Prelude.hs new file mode 100644 index 0000000..d29ef69 --- /dev/null +++ b/SC/Prelude.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module SC.Prelude where + +import Data.FileEmbed + + +prelude :: String +prelude = $(embedStringFile "prelude.c") diff --git a/accelerate-sc.cabal b/accelerate-sc.cabal index 1cb3060..6283c53 100644 --- a/accelerate-sc.cabal +++ b/accelerate-sc.cabal @@ -9,18 +9,23 @@ build-type: Simple library exposed-modules: + Data.Array.Accelerate.C other-modules: + Data.Array.Accelerate.Trafo.UnDelayed Language.C Language.C.Print SC.Acc + SC.Afun SC.Defs SC.Exp SC.Monad + SC.Prelude build-depends: base >= 4.13 && < 4.15, containers >= 0.6.3.1 && < 0.7, accelerate ^>= 1.3.0.0, - transformers >= 0.5.6 && < 0.7 + transformers >= 0.5.6 && < 0.7, + file-embed ^>= 0.0.15 hs-source-dirs: . default-language: Haskell2010 ghc-options: -Wall -O2 @@ -1,4 +1,7 @@ -int builtin_divInt(int x, int y) { +#include <stdlib.h> +#include <stdint.h> + +/*int builtin_divInt(int x, int y) { return (x > 0 && y < 0) ? (x - 1) / y - 1 : (x < 0 && y > 0) ? (x + 1) / y - 1 @@ -10,4 +13,4 @@ int builtin_modInt(int x, int y) { (x > 0 && y < 0) ? (x - 1) % y + y + 1 : (x < 0 && y > 0) ? (x + 1) % y + y - 1 : x % y; -} +}*/ |