blob: 0ecf9cd34b6db9398ed3afcc63c759e188ea57a4 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
{-# 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(..))
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
itupEvars :: ITup TypedName t -> Exprs t
itupEvars = itupmap (\(TypedName _ n) -> C.EVar n)
-- 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
ANPair :: TupANames a -> TupANames b -> TupANames (a, b)
ANArray :: ShNames sh -> ANames t -> TupANames (Array sh t)
ANIgnore :: TupANames a
-- Shape names and data array names
tupanamesList :: TupANames t -> ([TypedName], [TypedAName])
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 :: ShNames sh -> Name -> ShNames (sh, Int)
deriving instance Show (ShNames sh)
shnamesList :: ShNames sh -> [TypedName]
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 (makeShNames sht ns) n
makeShNames _ _ = error "wat"
fromShNames :: ShNames sh -> ITup TypedName sh
fromShNames ShZ = ITupIgnore
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)
-- 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"
|
