4 import qualified Control.Monad as Monad
5 import qualified Data.Map as Map
11 import qualified ForSyDe.Backend.VHDL.AST as AST
25 -- | A function to wrap a builder-like function that expects its arguments to
28 (dst -> func -> [AST.Expr] -> res)
29 -> (dst -> func -> [CoreSyn.CoreExpr] -> res)
30 genExprArgs wrap dst func args = wrap dst func args'
31 where args' = map (varToVHDLExpr.exprToVar) args
33 -- | A function to wrap a builder-like function that expects its arguments to
36 (dst -> func -> [Var.Var] -> res)
37 -> (dst -> func -> [CoreSyn.CoreExpr] -> res)
38 genVarArgs wrap dst func args = wrap dst func args'
39 where args' = map exprToVar args
41 -- | A function to wrap a builder-like function that produces an expression
42 -- and expects it to be assigned to the destination.
44 (CoreSyn.CoreBndr -> func -> [arg] -> VHDLSession AST.Expr)
45 -> (CoreSyn.CoreBndr -> func -> [arg] -> VHDLSession [AST.ConcSm])
46 genExprRes wrap dst func args = do
47 expr <- wrap dst func args
48 return $ [mkUncondAssign (Left dst) expr]
50 -- | Generate a binary operator application. The first argument should be a
51 -- constructor from the AST.Expr type, e.g. AST.And.
52 genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder
53 genOperator2 op = genExprArgs $ genExprRes (genOperator2' op)
54 genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> CoreSyn.CoreBndr -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
55 genOperator2' op res f [arg1, arg2] = return $ op arg1 arg2
57 -- | Generate a unary operator application
58 genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder
59 genOperator1 op = genExprArgs $ genExprRes (genOperator1' op)
60 genOperator1' :: (AST.Expr -> AST.Expr) -> CoreSyn.CoreBndr -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
61 genOperator1' op res f [arg] = return $ op arg
63 -- | Generate a function call from the destination binder, function name and a
64 -- list of expressions (its arguments)
65 genFCall :: BuiltinBuilder
66 genFCall = genExprArgs $ genExprRes genFCall'
67 genFCall' :: CoreSyn.CoreBndr -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
68 genFCall' res f args = do
69 let fname = varToString f
70 let el_ty = (tfvec_elem . Var.varType) res
71 id <- vectorFunId el_ty fname
72 return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $
73 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
75 -- | Generate a generate statement for the builtin function "map"
76 genMap :: BuiltinBuilder
77 genMap = genVarArgs genMap'
78 genMap' res f [mapped_f, arg] = do
79 signatures <- getA vsSignatures
80 let entity = Maybe.fromMaybe
81 (error $ "Using function '" ++ (varToString mapped_f) ++ "' without signature? This should not happen!")
82 (Map.lookup mapped_f signatures)
84 -- Setup the generate scheme
85 len = (tfvec_len . Var.varType) res
86 label = mkVHDLExtId ("mapVector" ++ (varToString res))
87 nPar = AST.unsafeVHDLBasicId "n"
88 range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
89 genScheme = AST.ForGn nPar range
90 -- Get the entity name and port names
91 entity_id = ent_id entity
92 argports = map (Monad.liftM fst) (ent_args entity)
93 resport = (Monad.liftM fst) (ent_res entity)
95 inport = mkAssocElemIndexed (argports!!0) (varToVHDLId arg) nPar
96 outport = mkAssocElemIndexed resport (varToVHDLId res) nPar
97 portassigns = Maybe.catMaybes [inport,outport]
98 -- Generate the portmap
99 mapLabel = "map" ++ (AST.fromVHDLId entity_id)
100 compins = mkComponentInst mapLabel entity_id portassigns
101 -- Return the generate functions
102 genSm = AST.CSGSm $ AST.GenerateSm label genScheme [] [compins]
106 genZipWith :: BuiltinBuilder
107 genZipWith = genVarArgs genZipWith'
108 genZipWith' res f args@[zipped_f, arg1, arg2] = do
109 signatures <- getA vsSignatures
110 let entity = Maybe.fromMaybe
111 (error $ "Using function '" ++ (varToString zipped_f) ++ "' without signature? This should not happen!")
112 (Map.lookup zipped_f signatures)
114 -- Setup the generate scheme
115 len = (tfvec_len . Var.varType) res
116 label = mkVHDLExtId ("zipWithVector" ++ (varToString res))
117 nPar = AST.unsafeVHDLBasicId "n"
118 range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
119 genScheme = AST.ForGn nPar range
120 -- Get the entity name and port names
121 entity_id = ent_id entity
122 argports = map (Monad.liftM fst) (ent_args entity)
123 resport = (Monad.liftM fst) (ent_res entity)
125 inport1 = mkAssocElemIndexed (argports!!0) (varToVHDLId arg1) nPar
126 inport2 = mkAssocElemIndexed (argports!!1) (varToVHDLId arg2) nPar
127 outport = mkAssocElemIndexed resport (varToVHDLId res) nPar
128 portassigns = Maybe.catMaybes [inport1,inport2,outport]
129 -- Generate the portmap
130 mapLabel = "zipWith" ++ (AST.fromVHDLId entity_id)
131 compins = mkComponentInst mapLabel entity_id portassigns
132 -- Return the generate functions
133 genSm = AST.CSGSm $ AST.GenerateSm label genScheme [] [compins]
137 genFoldl :: BuiltinBuilder
138 genFoldl = genVarArgs genFoldl'
139 genFoldl' resVal f [folded_f, startVal, inVec] = do
140 signatures <- getA vsSignatures
141 let entity = Maybe.fromMaybe
142 (error $ "Using function '" ++ (varToString folded_f) ++ "' without signature? This should not happen!")
143 (Map.lookup folded_f signatures)
144 let (vec, _) = splitAppTy (Var.varType inVec)
145 let vecty = Type.mkAppTy vec (Var.varType startVal)
146 vecType <- vhdl_ty vecty
147 -- Setup the generate scheme
148 let len = (tfvec_len . Var.varType) inVec
149 let genlabel = mkVHDLExtId ("foldlVector" ++ (varToString inVec))
150 let blockLabel = mkVHDLExtId ("foldlVector" ++ (varToString startVal))
151 let range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
152 let genScheme = AST.ForGn (AST.unsafeVHDLBasicId "n") range
153 -- Make the intermediate vector
154 let tmpVec = AST.BDISD $ AST.SigDec (mkVHDLExtId "tmp") vecType Nothing
155 -- Get the entity name and port names
156 let entity_id = ent_id entity
157 let argports = map (Monad.liftM fst) (ent_args entity)
158 let resport = (Monad.liftM fst) (ent_res entity)
159 -- Return the generate functions
160 let genSm = AST.GenerateSm genlabel genScheme []
161 [ AST.CSGSm (genFirstCell (entity_id, argports, resport)
162 [startVal, inVec, resVal])
163 , AST.CSGSm (genOtherCell (entity_id, argports, resport)
164 [startVal, inVec, resVal])
165 , AST.CSGSm (genLastCell (entity_id, argports, resport)
166 [startVal, inVec, resVal])
168 return $ [AST.CSBSm $ AST.BlockSm blockLabel [] (AST.PMapAspect []) [tmpVec] [AST.CSGSm genSm]]
170 genFirstCell (entity_id, argports, resport) [startVal, inVec, resVal] = cellGn
172 cellLabel = mkVHDLExtId "firstcell"
173 cellGenScheme = AST.IfGn ((AST.PrimName $ AST.NSimple nPar) AST.:=: (AST.PrimLit "0"))
174 tmpId = mkVHDLExtId "tmp"
175 nPar = AST.unsafeVHDLBasicId "n"
177 inport1 = mkAssocElem (argports!!0) (varToString startVal)
178 inport2 = mkAssocElemIndexed (argports!!1) (varToVHDLId inVec) nPar
179 outport = mkAssocElemIndexed resport tmpId nPar
180 portassigns = Maybe.catMaybes [inport1,inport2,outport]
181 -- Generate the portmap
182 mapLabel = "cell" ++ (AST.fromVHDLId entity_id)
183 compins = mkComponentInst mapLabel entity_id portassigns
184 -- Return the generate functions
185 cellGn = AST.GenerateSm cellLabel cellGenScheme [] [compins]
186 genOtherCell (entity_id, argports, resport) [startVal, inVec, resVal] = cellGn
188 len = (tfvec_len . Var.varType) inVec
189 cellLabel = mkVHDLExtId "othercell"
190 cellGenScheme = AST.IfGn $ AST.And ((AST.PrimName $ AST.NSimple nPar) AST.:>: (AST.PrimLit "0"))
191 ((AST.PrimName $ AST.NSimple nPar) AST.:<: (AST.PrimLit $ show (len-1)))
192 tmpId = mkVHDLExtId "tmp"
193 nPar = AST.unsafeVHDLBasicId "n"
195 inport1 = mkAssocElemIndexed (argports!!0) tmpId (AST.unsafeVHDLBasicId "n-1")
196 inport2 = mkAssocElemIndexed (argports!!1) (varToVHDLId inVec) nPar
197 outport = mkAssocElemIndexed resport tmpId nPar
198 portassigns = Maybe.catMaybes [inport1,inport2,outport]
199 -- Generate the portmap
200 mapLabel = "cell" ++ (AST.fromVHDLId entity_id)
201 compins = mkComponentInst mapLabel entity_id portassigns
202 -- Return the generate functions
203 cellGn = AST.GenerateSm cellLabel cellGenScheme [] [compins]
204 genLastCell (entity_id, argports, resport) [startVal, inVec, resVal] = cellGn
206 len = (tfvec_len . Var.varType) inVec
207 cellLabel = mkVHDLExtId "lastCell"
208 cellGenScheme = AST.IfGn ((AST.PrimName $ AST.NSimple nPar) AST.:=: (AST.PrimLit $ show (len-1)))
209 tmpId = mkVHDLExtId "tmp"
210 nPar = AST.unsafeVHDLBasicId "n"
212 inport1 = mkAssocElemIndexed (argports!!0) tmpId (AST.unsafeVHDLBasicId "n-1")
213 inport2 = mkAssocElemIndexed (argports!!1) (varToVHDLId inVec) nPar
214 outport = mkAssocElemIndexed resport tmpId nPar
215 portassigns = Maybe.catMaybes [inport1,inport2,outport]
216 -- Generate the portmap
217 mapLabel = "cell" ++ (AST.fromVHDLId entity_id)
218 compins = mkComponentInst mapLabel entity_id portassigns
219 -- Generate the output assignment
220 assign = mkUncondAssign (Left resVal) (AST.PrimName (AST.NIndexed (AST.IndexedName
221 (AST.NSimple tmpId) [AST.PrimLit $ show (len-1)])))
222 -- Return the generate functions
223 cellGn = AST.GenerateSm cellLabel cellGenScheme [] [compins,assign]
226 -- Returns the VHDLId of the vector function with the given name for the given
227 -- element type. Generates -- this function if needed.
228 vectorFunId :: Type.Type -> String -> VHDLSession AST.VHDLId
229 vectorFunId el_ty fname = do
230 elemTM <- vhdl_ty el_ty
231 -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
232 -- the VHDLState or something.
233 let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
234 typefuns <- getA vsTypeFuns
235 case Map.lookup (OrdType el_ty, fname) typefuns of
236 -- Function already generated, just return it
237 Just (id, _) -> return id
238 -- Function not generated yet, generate it
240 let functions = genUnconsVectorFuns elemTM vectorTM
241 case lookup fname functions of
243 modA vsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, body)
245 Nothing -> error $ "I don't know how to generate vector function " ++ fname
247 function_id = mkVHDLExtId fname
249 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
250 -> AST.TypeMark -- ^ type of the vector
251 -> [(String, AST.SubProgBody)]
252 genUnconsVectorFuns elemTM vectorTM =
253 [ (exId, AST.SubProgBody exSpec [] [exExpr])
254 , (replaceId, AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet])
255 , (headId, AST.SubProgBody headSpec [] [headExpr])
256 , (lastId, AST.SubProgBody lastSpec [] [lastExpr])
257 , (initId, AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet])
258 , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet])
259 , (takeId, AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet])
260 , (dropId, AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet])
261 , (plusgtId, AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet])
262 , (emptyId, AST.SubProgBody emptySpec [AST.SPCD emptyVar] [emptyExpr])
263 , (singletonId, AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet])
264 , (copyId, AST.SubProgBody copySpec [AST.SPVD copyVar] [copyExpr])
267 ixPar = AST.unsafeVHDLBasicId "ix"
268 vecPar = AST.unsafeVHDLBasicId "vec"
269 nPar = AST.unsafeVHDLBasicId "n"
270 iId = AST.unsafeVHDLBasicId "i"
272 aPar = AST.unsafeVHDLBasicId "a"
273 resId = AST.unsafeVHDLBasicId "res"
274 exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
275 AST.IfaceVarDec ixPar naturalTM] elemTM
276 exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
277 (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $
279 replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
280 , AST.IfaceVarDec iPar naturalTM
281 , AST.IfaceVarDec aPar elemTM
283 -- variable res : fsvec_x (0 to vec'length-1);
286 (AST.SubtypeIn vectorTM
287 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
288 [AST.ToRange (AST.PrimLit "0")
289 (AST.PrimName (AST.NAttribute $
290 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
291 (AST.PrimLit "1")) ]))
293 -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
294 replaceExpr = AST.NSimple resId AST.:=
295 (vecSlice (AST.PrimLit "0") (AST.PrimName (AST.NSimple iPar) AST.:-: AST.PrimLit "1") AST.:&:
296 AST.PrimName (AST.NSimple aPar) AST.:&:
297 vecSlice (AST.PrimName (AST.NSimple iPar) AST.:+: AST.PrimLit "1")
298 ((AST.PrimName (AST.NAttribute $
299 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))
300 AST.:-: AST.PrimLit "1"))
301 replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
302 vecSlice init last = AST.PrimName (AST.NSlice
305 (AST.ToRange init last)))
306 headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
308 headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
309 (AST.NSimple vecPar) [AST.PrimLit "0"])))
310 lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
311 -- return vec(vec'length-1);
312 lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
314 [AST.PrimName (AST.NAttribute $
315 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
316 AST.:-: AST.PrimLit "1"])))
317 initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
318 -- variable res : fsvec_x (0 to vec'length-2);
321 (AST.SubtypeIn vectorTM
322 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
323 [AST.ToRange (AST.PrimLit "0")
324 (AST.PrimName (AST.NAttribute $
325 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
326 (AST.PrimLit "2")) ]))
328 -- resAST.:= vec(0 to vec'length-2)
329 initExpr = AST.NSimple resId AST.:= (vecSlice
331 (AST.PrimName (AST.NAttribute $
332 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
333 AST.:-: AST.PrimLit "2"))
334 initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
335 tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
336 -- variable res : fsvec_x (0 to vec'length-2);
339 (AST.SubtypeIn vectorTM
340 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
341 [AST.ToRange (AST.PrimLit "0")
342 (AST.PrimName (AST.NAttribute $
343 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
344 (AST.PrimLit "2")) ]))
346 -- res AST.:= vec(1 to vec'length-1)
347 tailExpr = AST.NSimple resId AST.:= (vecSlice
349 (AST.PrimName (AST.NAttribute $
350 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
351 AST.:-: AST.PrimLit "1"))
352 tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
353 takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,
354 AST.IfaceVarDec vecPar vectorTM ] vectorTM
355 -- variable res : fsvec_x (0 to n-1);
358 (AST.SubtypeIn vectorTM
359 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
360 [AST.ToRange (AST.PrimLit "0")
361 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
362 (AST.PrimLit "1")) ]))
364 -- res AST.:= vec(0 to n-1)
365 takeExpr = AST.NSimple resId AST.:=
366 (vecSlice (AST.PrimLit "1")
367 (AST.PrimName (AST.NSimple $ nPar) AST.:-: AST.PrimLit "1"))
368 takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
369 dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM,
370 AST.IfaceVarDec vecPar vectorTM ] vectorTM
371 -- variable res : fsvec_x (0 to vec'length-n-1);
374 (AST.SubtypeIn vectorTM
375 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
376 [AST.ToRange (AST.PrimLit "0")
377 (AST.PrimName (AST.NAttribute $
378 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
379 (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
381 -- res AST.:= vec(n to vec'length-1)
382 dropExpr = AST.NSimple resId AST.:= (vecSlice
383 (AST.PrimName $ AST.NSimple nPar)
384 (AST.PrimName (AST.NAttribute $
385 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
386 AST.:-: AST.PrimLit "1"))
387 dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
388 plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
389 AST.IfaceVarDec vecPar vectorTM] vectorTM
390 -- variable res : fsvec_x (0 to vec'length);
393 (AST.SubtypeIn vectorTM
394 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
395 [AST.ToRange (AST.PrimLit "0")
396 (AST.PrimName (AST.NAttribute $
397 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))]))
399 plusgtExpr = AST.NSimple resId AST.:=
400 ((AST.PrimName $ AST.NSimple aPar) AST.:&:
401 (AST.PrimName $ AST.NSimple vecPar))
402 plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
403 emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
406 (AST.SubtypeIn vectorTM Nothing)
407 (Just $ AST.PrimLit "\"\"")
408 emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
409 singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
411 -- variable res : fsvec_x (0 to 0) := (others => a);
414 (AST.SubtypeIn vectorTM
415 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
416 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
417 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
418 (AST.PrimName $ AST.NSimple aPar)])
419 singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
420 copySpec = AST.Function (mkVHDLExtId copyId) [AST.IfaceVarDec nPar naturalTM,
421 AST.IfaceVarDec aPar elemTM ] vectorTM
422 -- variable res : fsvec_x (0 to n-1) := (others => a);
425 (AST.SubtypeIn vectorTM
426 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
427 [AST.ToRange (AST.PrimLit "0")
428 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
429 (AST.PrimLit "1")) ]))
430 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
431 (AST.PrimName $ AST.NSimple aPar)])
433 copyExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)