/
Tuple.hs
191 lines (165 loc) · 7.96 KB
/
Tuple.hs
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
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
{-# LANGUAGE QuasiQuotes #-}
-- |
-- Module : Data.Array.Accelerate.OpenCL.CodeGen.Tuple
-- Copyright : [2011] Martin Dybdal
-- License : BSD3
--
-- Maintainer : Martin Dybdal <dybber@dybber.dk>
-- Stability : experimental
-- Portability : non-partable (GHC extensions)
--
module Data.Array.Accelerate.OpenCL.CodeGen.Tuple
(
mkInputTuple, mkOutputTuple, --Accessor (..),
mkTupleTypeAsc, Arguments,
mkParameterList
-- mkTupleType, mkTuplePartition
)
where
import Data.Maybe
import Data.Char
-- Quasiquotation library
import Language.C.Quote.OpenCL
import Language.C hiding (mkPtr)
import qualified Language.C.Syntax
import qualified Data.Loc
import qualified Data.Symbol
import Data.Array.Accelerate.OpenCL.CodeGen.Monad
import Control.Monad
import Data.Array.Accelerate.OpenCL.CodeGen.Util
-- data Accessor = Get (String -> Exp)
-- | Set (String -> String -> Exp)
type Arguments = [Exp]
mkInputTuple :: String -> [Type]-> CGM Arguments
mkInputTuple subscript = mkTupleType (Just subscript)
mkOutputTuple :: [Type]-> CGM Arguments
mkOutputTuple = mkTupleType Nothing
mkTupleType :: Maybe String -> [Type] -> CGM Arguments
mkTupleType subscript types = do
let n = length types
tuple_name = maybe "TyOut" ("TyIn" ++) subscript
volatile = isNothing subscript
tynames
| n > 1 = take n [tuple_name ++ "_" ++ show i | i <- [0..]] -- TyInA_0, TyInA_1, ...
| otherwise = [tuple_name]
addDefinitions $ zipWith (mkTypedef volatile) tynames types
when (n > 1) $ addDefinition (mkStruct tuple_name volatile $ map typename tynames)
(args,ps) <- mkParameterList Global subscript n tynames
(_,psLocal) <- mkParameterList Local subscript n tynames
(maybe mkSet mkGet subscript) n ps Global
(maybe mkSet mkGet subscript) n psLocal Local
addParams ps
return args
mkInputTypedef :: String -> Int -> CGM Arguments
mkInputTypedef subscript n = do
let tuple_name = "TyIn" ++ subscript
tynames_in
| n > 1 = take n [tuple_name ++ "_" ++ show i | i <- [0..]] -- TyInA_0, TyInA_1, ...
| otherwise = [tuple_name]
tynames_out
| n > 1 = take n ["TyOut" ++ "_" ++ show i | i <- [0..]] -- TyInA_0, TyInA_1, ...
| otherwise = ["TyOut"]
addDefinitions $ zipWith (mkTypedef True) tynames_in $ map typename tynames_out
when (n > 1) $ addDefinition $ mkTypedef False tuple_name (typename "TyOut")
(args,ps) <- mkParameterList Global (Just subscript) n tynames_in
(_,psLocal) <- mkParameterList Local (Just subscript) n tynames_in
mkGet subscript n ps Global
mkGet subscript n psLocal Local
addParams ps
return args
mkTupleTypeAsc :: Int -> [Type] -> CGM (Arguments, [Arguments])
mkTupleTypeAsc cargs typ = do
argsOut <- mkOutputTuple typ
let names = [ [chr $ ord 'A' + i] | i <- [0..cargs-1]]
argsIn <- mapM (flip mkInputTypedef $ length typ) names
return $ (argsOut, argsIn)
-- mkLocalAccessors :: Int -> [Type] -> CGM ()
-- mkLocalAccessors subscript types = do
-- let names = [ [chr $ ord 'A' + i] | i <- [0..n-1]]
-- n = length types
-- tynames
-- | n > 1 = take n [tuple_name ++ "_" ++ show i | i <- [0..]] -- TyInA_0, TyInA_1, ...
-- | otherwise = [tuple_name]
-- (argsOut, psout) <- mkParameterList Local Nothing n
-- argsIn <- mapM (flip mkInputTuple typ) names
-- return $ (argsOut, argsIn)
mkParameterList :: StorageQual -> Maybe String -> Int -> [String] -> CGM (Arguments, [Param])
mkParameterList storage subscript n tynames = do
let ps = params (zip types' param_names)
return (args, ps)
where
param_prefix = maybe "out" ("in" ++) subscript
param_names
| n > 1 = take n [param_prefix ++ "_" ++ show i | i <- [0..]] -- inA_0, inB_0, ..
| otherwise = [param_prefix] -- inA or out
types' = map (mkPtr . changeStorage storage . typename) tynames
args = map (\p -> [cexp|$id:p|]) param_names
mkGet :: String -> Int -> [Param] -> StorageQual -> CGM ()
mkGet prj n params storage = do
addDefinition
[cedecl|
inline $ty:returnType $id:name($ty:ix idx, $params:params) {
$ty:returnType val;
$stms:assignments
return val;
}
|]
where
parnames = ["in" ++ prj ++ "_" ++ show i | i <- [0..]]
name | storage == Local = "get" ++ prj ++ "_local"
| otherwise = "get" ++ prj
returnType = typename $ "TyIn" ++ prj
assign i name = let field = 'a' : show i
in [cstm|val.$id:field = $id:name [idx];|]
assignments
| n > 1 = take n $ zipWith assign [0..] parnames
| otherwise = [ [cstm|val = $id:("in" ++ prj) [idx];|] ]
mkSet :: Int -> [Param] -> StorageQual -> CGM ()
mkSet n params storage =
addDefinition
[cedecl|
inline void $id:name($ty:ix idx, const $ty:outType val, $params:params) {
$stms:assignments
}
|]
where
name | storage == Local = "set_local"
| otherwise = "set"
parnames = ["out" ++ "_" ++ show i | i <- [0..]]
assign i name = let field = 'a' : show i
in [cstm|$id:name [idx] = val.$id:field;|]
assignments
| n > 1 = take n $ zipWith assign [0..] parnames
| otherwise = [ [cstm|out[idx] = val;|] ]
-- TODO partition
-- -- A variant of tuple generation for associative array computations, generating
-- -- base get and set functions, and the given number of type synonyms.
-- --
-- mkTupleTypeAsc :: Int -> [CType] -> [CExtDecl]
-- mkTupleTypeAsc syn ty = types ++ synonyms ++ [mkSet n, mkGet n 0]
-- where
-- n = length ty
-- synonyms = concat . take syn . flip map ([0..] :: [Int]) $ \v ->
-- [ mkTypedef ("TyIn" ++ show v) False False [CTypeDef (internalIdent "TyOut") internalNode]
-- , mkTypedef ("ArrIn" ++ show v) False False [CTypeDef (internalIdent "ArrOut") internalNode] ]
-- types
-- | n <= 1 = [ mkTypedef "TyOut" False False (head ty), mkTypedef "ArrOut" True True (head ty)]
-- | otherwise = [ mkStruct "TyOut" False False ty, mkStruct "ArrOut" True True ty]
-- mkTuplePartition :: String -> [CType] -> Bool -> CExtDecl
-- mkTuplePartition tyName ty isVolatile =
-- CFDefExt
-- (CFunDef
-- [CStorageSpec (CStatic internalNode),CTypeQual (CInlineQual internalNode),CTypeQual (CAttrQual (CAttr (internalIdent "device") [] internalNode)),CTypeSpec (CTypeDef (internalIdent tyName) internalNode)]
-- (CDeclr (Just (internalIdent "partition")) [CFunDeclr (Right ([CDecl [CTypeQual (CConstQual internalNode),CTypeSpec (CVoidType internalNode)] [(Just (CDeclr (Just (internalIdent "s_data")) [CPtrDeclr [] internalNode] Nothing [] internalNode),Nothing,Nothing)] internalNode,CDecl [CTypeQual (CConstQual internalNode),CTypeSpec (CIntType internalNode)] [(Just (CDeclr (Just (internalIdent "n")) [] Nothing [] internalNode),Nothing,Nothing)] internalNode],False)) [] internalNode] Nothing [] internalNode)
-- []
-- (CCompound [] (stmts ++ [CBlockDecl (CDecl [CTypeSpec (CTypeDef (internalIdent tyName) internalNode)] [(Just (CDeclr (Just (internalIdent "r")) [] Nothing [] internalNode),Just initp,Nothing)] internalNode) ,CBlockStmt (CReturn (Just (CVar (internalIdent "r") internalNode)) internalNode)]) internalNode)
-- internalNode)
-- where
-- n = length ty
-- var s = CVar (internalIdent s) internalNode
-- names = map (('p':) . show) [n-1,n-2..0]
-- initp = mkInitList (map var names)
-- volat = [CTypeQual (CVolatQual internalNode) | isVolatile]
-- stmts = zipWith (\l r -> CBlockDecl (CDecl (volat ++ map CTypeSpec l) r internalNode)) ty
-- . zipWith3 (\p t s -> [(Just (CDeclr (Just (internalIdent p)) [CPtrDeclr [] internalNode] Nothing [] internalNode),Just (CInitExpr (CCast (CDecl (map CTypeSpec t) [(Just (CDeclr Nothing [CPtrDeclr [] internalNode] Nothing [] internalNode),Nothing,Nothing)] internalNode) s internalNode) internalNode),Nothing)]) names ty
-- $ var "s_data" : map (\v -> CUnary CAdrOp (CIndex (var v) (CVar (internalIdent "n") internalNode) internalNode) internalNode) names