4 import qualified Control.Monad as Monad
5 import qualified Data.Map as Map
10 import qualified ForSyDe.Backend.VHDL.AST as AST
23 -- | Generate a binary operator application. The first argument should be a
24 -- constructor from the AST.Expr type, e.g. AST.And.
25 genExprOp2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
26 genExprOp2 op res [arg1, arg2] = return $ op arg1 arg2
28 -- | Generate a unary operator application
29 genExprOp1 :: (AST.Expr -> AST.Expr) -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
30 genExprOp1 op res [arg] = return $ op arg
32 -- | Generate a function call from the destination binder, function name and a
33 -- list of expressions (its arguments)
34 genExprFCall :: String -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
35 genExprFCall fname res args = do
36 let el_ty = (tfvec_elem . Var.varType) res
37 id <- vectorFunId el_ty fname
38 return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $
39 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
41 -- | Generate a generate statement for the builtin function "map"
43 Entity -- | The entity to map
44 -> [CoreSyn.CoreBndr] -- | The vectors
45 -> VHDLSession AST.ConcSm -- | The resulting generate statement
46 genMapCall entity [arg, res] = return $ genSm
48 -- Setup the generate scheme
49 len = (tfvec_len . Var.varType) res
50 label = mkVHDLExtId ("mapVector" ++ (varToString res))
51 nPar = AST.unsafeVHDLBasicId "n"
52 range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
53 genScheme = AST.ForGn nPar range
54 -- Get the entity name and port names
55 entity_id = ent_id entity
56 argports = map (Monad.liftM fst) (ent_args entity)
57 resport = (Monad.liftM fst) (ent_res entity)
59 inport = mkAssocElemIndexed (argports!!0) (varToString arg) nPar
60 outport = mkAssocElemIndexed resport (varToString res) nPar
61 clk_port = mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
62 portassigns = Maybe.catMaybes [inport,outport,clk_port]
63 -- Generate the portmap
64 mapLabel = "map" ++ (AST.fromVHDLId entity_id)
65 compins = mkComponentInst mapLabel entity_id portassigns
66 -- Return the generate functions
67 genSm = AST.CSGSm $ AST.GenerateSm label genScheme [] [compins]
72 -> VHDLSession AST.ConcSm
73 genZipWithCall entity [arg1, arg2, res] = return $ genSm
75 -- Setup the generate scheme
76 len = (tfvec_len . Var.varType) res
77 label = mkVHDLExtId ("zipWithVector" ++ (varToString res))
78 nPar = AST.unsafeVHDLBasicId "n"
79 range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
80 genScheme = AST.ForGn nPar range
81 -- Get the entity name and port names
82 entity_id = ent_id entity
83 argports = map (Monad.liftM fst) (ent_args entity)
84 resport = (Monad.liftM fst) (ent_res entity)
86 inport1 = mkAssocElemIndexed (argports!!0) (varToString arg1) nPar
87 inport2 = mkAssocElemIndexed (argports!!1) (varToString arg2) nPar
88 outport = mkAssocElemIndexed resport (varToString res) nPar
89 clk_port = mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
90 portassigns = Maybe.catMaybes [inport1,inport2,outport,clk_port]
91 -- Generate the portmap
92 mapLabel = "zipWith" ++ (AST.fromVHDLId entity_id)
93 compins = mkComponentInst mapLabel entity_id portassigns
94 -- Return the generate functions
95 genSm = AST.CSGSm $ AST.GenerateSm label genScheme [] [compins]
100 -> VHDLSession AST.ConcSm
101 genFoldlCall entity [startVal, inVec, resVal] = do
102 let (vec, _) = splitAppTy (Var.varType inVec)
103 let vecty = Type.mkAppTy vec (Var.varType startVal)
104 vecType <- vhdl_ty vecty
105 -- Setup the generate scheme
106 let len = (tfvec_len . Var.varType) inVec
107 let genlabel = mkVHDLExtId ("foldlVector" ++ (varToString inVec))
108 let blockLabel = mkVHDLExtId ("foldlVector" ++ (varToString startVal))
109 let nPar = AST.unsafeVHDLBasicId "n"
110 let range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
111 let genScheme = AST.ForGn nPar range
112 -- Make the intermediate vector
113 let tmpVec = AST.BDISD $ AST.SigDec (mkVHDLExtId "tmp") vecType Nothing
114 -- Return the generate functions
115 let genSm = AST.GenerateSm genlabel genScheme [] [ AST.CSGSm (genFirstCell entity [startVal, inVec, resVal])
116 , AST.CSGSm (genOtherCell entity [startVal, inVec, resVal])
117 , AST.CSGSm (genLastCell entity [startVal, inVec, resVal])
119 return $ AST.CSBSm $ AST.BlockSm blockLabel [] (AST.PMapAspect []) [tmpVec] [AST.CSGSm genSm]
121 genFirstCell :: Entity -> [CoreSyn.CoreBndr] -> AST.GenerateSm
122 genFirstCell entity [startVal, inVec, resVal] = cellGn
124 cellLabel = mkVHDLExtId "firstcell"
125 cellGenScheme = AST.IfGn ((AST.PrimName $ AST.NSimple nPar) AST.:=: (AST.PrimLit "0"))
126 nPar = AST.unsafeVHDLBasicId "n"
127 -- Get the entity name and port names
128 entity_id = ent_id entity
129 argports = map (Monad.liftM fst) (ent_args entity)
130 resport = (Monad.liftM fst) (ent_res entity)
132 inport1 = mkAssocElem (argports!!0) (varToString startVal)
133 inport2 = mkAssocElemIndexed (argports!!1) (varToString inVec) nPar
134 outport = mkAssocElemIndexed resport "tmp" nPar
135 clk_port = mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
136 portassigns = Maybe.catMaybes [inport1,inport2,outport,clk_port]
137 -- Generate the portmap
138 mapLabel = "cell" ++ (AST.fromVHDLId entity_id)
139 compins = mkComponentInst mapLabel entity_id portassigns
140 -- Return the generate functions
141 cellGn = AST.GenerateSm cellLabel cellGenScheme [] [compins]
142 genOtherCell :: Entity -> [CoreSyn.CoreBndr] -> AST.GenerateSm
143 genOtherCell entity [startVal, inVec, resVal] = cellGn
145 len = (tfvec_len . Var.varType) inVec
146 cellLabel = mkVHDLExtId "othercell"
147 cellGenScheme = AST.IfGn $ AST.And ((AST.PrimName $ AST.NSimple nPar) AST.:>: (AST.PrimLit "0"))
148 ((AST.PrimName $ AST.NSimple nPar) AST.:<: (AST.PrimLit $ show (len-1)))
149 nPar = AST.unsafeVHDLBasicId "n"
150 -- Get the entity name and port names
151 entity_id = ent_id entity
152 argports = map (Monad.liftM fst) (ent_args entity)
153 resport = (Monad.liftM fst) (ent_res entity)
155 inport1 = mkAssocElemIndexed (argports!!0) "tmp" (AST.unsafeVHDLBasicId "n-1")
156 inport2 = mkAssocElemIndexed (argports!!1) (varToString inVec) nPar
157 outport = mkAssocElemIndexed resport "tmp" nPar
158 clk_port = mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
159 portassigns = Maybe.catMaybes [inport1,inport2,outport,clk_port]
160 -- Generate the portmap
161 mapLabel = "cell" ++ (AST.fromVHDLId entity_id)
162 compins = mkComponentInst mapLabel entity_id portassigns
163 -- Return the generate functions
164 cellGn = AST.GenerateSm cellLabel cellGenScheme [] [compins]
165 genLastCell :: Entity -> [CoreSyn.CoreBndr] -> AST.GenerateSm
166 genLastCell entity [startVal, inVec, resVal] = cellGn
168 len = (tfvec_len . Var.varType) inVec
169 cellLabel = mkVHDLExtId "lastCell"
170 cellGenScheme = AST.IfGn ((AST.PrimName $ AST.NSimple nPar) AST.:=: (AST.PrimLit $ show (len-1)))
171 nPar = AST.unsafeVHDLBasicId "n"
172 -- Get the entity name and port names
173 entity_id = ent_id entity
174 argports = map (Monad.liftM fst) (ent_args entity)
175 resport = (Monad.liftM fst) (ent_res entity)
177 inport1 = mkAssocElemIndexed (argports!!0) "tmp" (AST.unsafeVHDLBasicId "n-1")
178 inport2 = mkAssocElemIndexed (argports!!1) (varToString inVec) nPar
179 outport = mkAssocElemIndexed resport "tmp" nPar
180 clk_port = mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
181 portassigns = Maybe.catMaybes [inport1,inport2,outport,clk_port]
182 -- Generate the portmap
183 mapLabel = "cell" ++ (AST.fromVHDLId entity_id)
184 compins = mkComponentInst mapLabel entity_id portassigns
185 -- Generate the output assignment
186 assign = mkUncondAssign (Left resVal) (AST.PrimName (AST.NIndexed (AST.IndexedName
187 (AST.NSimple (mkVHDLExtId "tmp")) [AST.PrimLit $ show (len-1)])))
188 -- Return the generate functions
189 cellGn = AST.GenerateSm cellLabel cellGenScheme [] [compins,assign]
192 -- Returns the VHDLId of the vector function with the given name for the given
193 -- element type. Generates -- this function if needed.
194 vectorFunId :: Type.Type -> String -> VHDLSession AST.VHDLId
195 vectorFunId el_ty fname = do
196 elemTM <- vhdl_ty el_ty
197 -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
198 -- the VHDLState or something.
199 let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
200 typefuns <- getA vsTypeFuns
201 case Map.lookup (OrdType el_ty, fname) typefuns of
202 -- Function already generated, just return it
203 Just (id, _) -> return id
204 -- Function not generated yet, generate it
206 let functions = genUnconsVectorFuns elemTM vectorTM
207 case lookup fname functions of
209 modA vsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, body)
211 Nothing -> error $ "I don't know how to generate vector function " ++ fname
213 function_id = mkVHDLExtId fname
215 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
216 -> AST.TypeMark -- ^ type of the vector
217 -> [(String, AST.SubProgBody)]
218 genUnconsVectorFuns elemTM vectorTM =
219 [ (exId, AST.SubProgBody exSpec [] [exExpr])
220 , (replaceId, AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet])
221 , (headId, AST.SubProgBody headSpec [] [headExpr])
222 , (lastId, AST.SubProgBody lastSpec [] [lastExpr])
223 , (initId, AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet])
224 , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet])
225 , (takeId, AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet])
226 , (dropId, AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet])
227 , (plusgtId, AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet])
228 , (emptyId, AST.SubProgBody emptySpec [AST.SPCD emptyVar] [emptyExpr])
229 , (singletonId, AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet])
230 , (copyId, AST.SubProgBody copySpec [AST.SPVD copyVar] [copyExpr])
233 ixPar = AST.unsafeVHDLBasicId "ix"
234 vecPar = AST.unsafeVHDLBasicId "vec"
235 nPar = AST.unsafeVHDLBasicId "n"
236 iId = AST.unsafeVHDLBasicId "i"
238 aPar = AST.unsafeVHDLBasicId "a"
239 resId = AST.unsafeVHDLBasicId "res"
240 exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
241 AST.IfaceVarDec ixPar naturalTM] elemTM
242 exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
243 (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $
245 replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
246 , AST.IfaceVarDec iPar naturalTM
247 , AST.IfaceVarDec aPar elemTM
249 -- variable res : fsvec_x (0 to vec'length-1);
252 (AST.SubtypeIn vectorTM
253 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
254 [AST.ToRange (AST.PrimLit "0")
255 (AST.PrimName (AST.NAttribute $
256 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
257 (AST.PrimLit "1")) ]))
259 -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
260 replaceExpr = AST.NSimple resId AST.:=
261 (vecSlice (AST.PrimLit "0") (AST.PrimName (AST.NSimple iPar) AST.:-: AST.PrimLit "1") AST.:&:
262 AST.PrimName (AST.NSimple aPar) AST.:&:
263 vecSlice (AST.PrimName (AST.NSimple iPar) AST.:+: AST.PrimLit "1")
264 ((AST.PrimName (AST.NAttribute $
265 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))
266 AST.:-: AST.PrimLit "1"))
267 replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
268 vecSlice init last = AST.PrimName (AST.NSlice
271 (AST.ToRange init last)))
272 headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
274 headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
275 (AST.NSimple vecPar) [AST.PrimLit "0"])))
276 lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
277 -- return vec(vec'length-1);
278 lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
280 [AST.PrimName (AST.NAttribute $
281 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
282 AST.:-: AST.PrimLit "1"])))
283 initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
284 -- variable res : fsvec_x (0 to vec'length-2);
287 (AST.SubtypeIn vectorTM
288 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
289 [AST.ToRange (AST.PrimLit "0")
290 (AST.PrimName (AST.NAttribute $
291 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
292 (AST.PrimLit "2")) ]))
294 -- resAST.:= vec(0 to vec'length-2)
295 initExpr = AST.NSimple resId AST.:= (vecSlice
297 (AST.PrimName (AST.NAttribute $
298 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
299 AST.:-: AST.PrimLit "2"))
300 initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
301 tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
302 -- variable res : fsvec_x (0 to vec'length-2);
305 (AST.SubtypeIn vectorTM
306 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
307 [AST.ToRange (AST.PrimLit "0")
308 (AST.PrimName (AST.NAttribute $
309 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
310 (AST.PrimLit "2")) ]))
312 -- res AST.:= vec(1 to vec'length-1)
313 tailExpr = AST.NSimple resId AST.:= (vecSlice
315 (AST.PrimName (AST.NAttribute $
316 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
317 AST.:-: AST.PrimLit "1"))
318 tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
319 takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,
320 AST.IfaceVarDec vecPar vectorTM ] vectorTM
321 -- variable res : fsvec_x (0 to n-1);
324 (AST.SubtypeIn vectorTM
325 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
326 [AST.ToRange (AST.PrimLit "0")
327 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
328 (AST.PrimLit "1")) ]))
330 -- res AST.:= vec(0 to n-1)
331 takeExpr = AST.NSimple resId AST.:=
332 (vecSlice (AST.PrimLit "1")
333 (AST.PrimName (AST.NSimple $ nPar) AST.:-: AST.PrimLit "1"))
334 takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
335 dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM,
336 AST.IfaceVarDec vecPar vectorTM ] vectorTM
337 -- variable res : fsvec_x (0 to vec'length-n-1);
340 (AST.SubtypeIn vectorTM
341 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
342 [AST.ToRange (AST.PrimLit "0")
343 (AST.PrimName (AST.NAttribute $
344 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
345 (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
347 -- res AST.:= vec(n to vec'length-1)
348 dropExpr = AST.NSimple resId AST.:= (vecSlice
349 (AST.PrimName $ AST.NSimple nPar)
350 (AST.PrimName (AST.NAttribute $
351 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
352 AST.:-: AST.PrimLit "1"))
353 dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
354 plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
355 AST.IfaceVarDec vecPar vectorTM] vectorTM
356 -- variable res : fsvec_x (0 to vec'length);
359 (AST.SubtypeIn vectorTM
360 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
361 [AST.ToRange (AST.PrimLit "0")
362 (AST.PrimName (AST.NAttribute $
363 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))]))
365 plusgtExpr = AST.NSimple resId AST.:=
366 ((AST.PrimName $ AST.NSimple aPar) AST.:&:
367 (AST.PrimName $ AST.NSimple vecPar))
368 plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
369 emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
372 (AST.SubtypeIn vectorTM Nothing)
373 (Just $ AST.PrimLit "\"\"")
374 emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
375 singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
377 -- variable res : fsvec_x (0 to 0) := (others => a);
380 (AST.SubtypeIn vectorTM
381 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
382 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
383 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
384 (AST.PrimName $ AST.NSimple aPar)])
385 singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
386 copySpec = AST.Function (mkVHDLExtId copyId) [AST.IfaceVarDec nPar naturalTM,
387 AST.IfaceVarDec aPar elemTM ] vectorTM
388 -- variable res : fsvec_x (0 to n-1) := (others => a);
391 (AST.SubtypeIn vectorTM
392 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
393 [AST.ToRange (AST.PrimLit "0")
394 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
395 (AST.PrimLit "1")) ]))
396 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
397 (AST.PrimName $ AST.NSimple aPar)])
399 copyExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)