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.GenerateSm -- | 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.GenerateSm label genScheme [] [compins]
72 -> VHDLSession AST.GenerateSm
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.GenerateSm label genScheme [] [compins]
97 -- Returns the VHDLId of the vector function with the given name for the given
98 -- element type. Generates -- this function if needed.
99 vectorFunId :: Type.Type -> String -> VHDLSession AST.VHDLId
100 vectorFunId el_ty fname = do
101 elemTM <- vhdl_ty el_ty
102 -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
103 -- the VHDLState or something.
104 let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
105 typefuns <- getA vsTypeFuns
106 case Map.lookup (OrdType el_ty, fname) typefuns of
107 -- Function already generated, just return it
108 Just (id, _) -> return id
109 -- Function not generated yet, generate it
111 let functions = genUnconsVectorFuns elemTM vectorTM
112 case lookup fname functions of
114 modA vsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, body)
116 Nothing -> error $ "I don't know how to generate vector function " ++ fname
118 function_id = mkVHDLExtId fname
120 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
121 -> AST.TypeMark -- ^ type of the vector
122 -> [(String, AST.SubProgBody)]
123 genUnconsVectorFuns elemTM vectorTM =
124 [ (exId, AST.SubProgBody exSpec [] [exExpr])
125 , (replaceId, AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet])
126 , (headId, AST.SubProgBody headSpec [] [headExpr])
127 , (lastId, AST.SubProgBody lastSpec [] [lastExpr])
128 , (initId, AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet])
129 , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet])
130 , (takeId, AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet])
131 , (dropId, AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet])
132 , (plusgtId, AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet])
133 , (emptyId, AST.SubProgBody emptySpec [AST.SPCD emptyVar] [emptyExpr])
134 , (singletonId, AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet])
135 , (copyId, AST.SubProgBody copySpec [AST.SPVD copyVar] [copyExpr])
138 ixPar = AST.unsafeVHDLBasicId "ix"
139 vecPar = AST.unsafeVHDLBasicId "vec"
140 nPar = AST.unsafeVHDLBasicId "n"
141 iId = AST.unsafeVHDLBasicId "i"
143 aPar = AST.unsafeVHDLBasicId "a"
144 resId = AST.unsafeVHDLBasicId "res"
145 exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
146 AST.IfaceVarDec ixPar naturalTM] elemTM
147 exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
148 (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $
150 replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
151 , AST.IfaceVarDec iPar naturalTM
152 , AST.IfaceVarDec aPar elemTM
154 -- variable res : fsvec_x (0 to vec'length-1);
157 (AST.SubtypeIn vectorTM
158 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
159 [AST.ToRange (AST.PrimLit "0")
160 (AST.PrimName (AST.NAttribute $
161 AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing) AST.:-:
162 (AST.PrimLit "1")) ]))
164 -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
165 replaceExpr = AST.NSimple resId AST.:=
166 (vecSlice (AST.PrimLit "0") (AST.PrimName (AST.NSimple iPar) AST.:-: AST.PrimLit "1") AST.:&:
167 AST.PrimName (AST.NSimple aPar) AST.:&:
168 vecSlice (AST.PrimName (AST.NSimple iPar) AST.:+: AST.PrimLit "1")
169 ((AST.PrimName (AST.NAttribute $
170 AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing))
171 AST.:-: AST.PrimLit "1"))
172 replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
173 vecSlice init last = AST.PrimName (AST.NSlice
176 (AST.ToRange init last)))
177 headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
179 headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
180 (AST.NSimple vecPar) [AST.PrimLit "0"])))
181 lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
182 -- return vec(vec'length-1);
183 lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
185 [AST.PrimName (AST.NAttribute $
186 AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing)
187 AST.:-: AST.PrimLit "1"])))
188 initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
189 -- variable res : fsvec_x (0 to vec'length-2);
192 (AST.SubtypeIn vectorTM
193 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
194 [AST.ToRange (AST.PrimLit "0")
195 (AST.PrimName (AST.NAttribute $
196 AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing) AST.:-:
197 (AST.PrimLit "2")) ]))
199 -- resAST.:= vec(0 to vec'length-2)
200 initExpr = AST.NSimple resId AST.:= (vecSlice
202 (AST.PrimName (AST.NAttribute $
203 AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing)
204 AST.:-: AST.PrimLit "2"))
205 initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
206 tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
207 -- variable res : fsvec_x (0 to vec'length-2);
210 (AST.SubtypeIn vectorTM
211 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
212 [AST.ToRange (AST.PrimLit "0")
213 (AST.PrimName (AST.NAttribute $
214 AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing) AST.:-:
215 (AST.PrimLit "2")) ]))
217 -- res AST.:= vec(1 to vec'length-1)
218 tailExpr = AST.NSimple resId AST.:= (vecSlice
220 (AST.PrimName (AST.NAttribute $
221 AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing)
222 AST.:-: AST.PrimLit "1"))
223 tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
224 takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,
225 AST.IfaceVarDec vecPar vectorTM ] vectorTM
226 -- variable res : fsvec_x (0 to n-1);
229 (AST.SubtypeIn vectorTM
230 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
231 [AST.ToRange (AST.PrimLit "0")
232 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
233 (AST.PrimLit "1")) ]))
235 -- res AST.:= vec(0 to n-1)
236 takeExpr = AST.NSimple resId AST.:=
237 (vecSlice (AST.PrimLit "1")
238 (AST.PrimName (AST.NSimple $ nPar) AST.:-: AST.PrimLit "1"))
239 takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
240 dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM,
241 AST.IfaceVarDec vecPar vectorTM ] vectorTM
242 -- variable res : fsvec_x (0 to vec'length-n-1);
245 (AST.SubtypeIn vectorTM
246 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
247 [AST.ToRange (AST.PrimLit "0")
248 (AST.PrimName (AST.NAttribute $
249 AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing) AST.:-:
250 (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
252 -- res AST.:= vec(n to vec'length-1)
253 dropExpr = AST.NSimple resId AST.:= (vecSlice
254 (AST.PrimName $ AST.NSimple nPar)
255 (AST.PrimName (AST.NAttribute $
256 AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing)
257 AST.:-: AST.PrimLit "1"))
258 dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
259 plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
260 AST.IfaceVarDec vecPar vectorTM] vectorTM
261 -- variable res : fsvec_x (0 to vec'length);
264 (AST.SubtypeIn vectorTM
265 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
266 [AST.ToRange (AST.PrimLit "0")
267 (AST.PrimName (AST.NAttribute $
268 AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing))]))
270 plusgtExpr = AST.NSimple resId AST.:=
271 ((AST.PrimName $ AST.NSimple aPar) AST.:&:
272 (AST.PrimName $ AST.NSimple vecPar))
273 plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
274 emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
277 (AST.SubtypeIn vectorTM Nothing)
278 (Just $ AST.PrimLit "\"\"")
279 emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
280 singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
282 -- variable res : fsvec_x (0 to 0) := (others => a);
285 (AST.SubtypeIn vectorTM
286 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
287 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
288 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
289 (AST.PrimName $ AST.NSimple aPar)])
290 singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
291 copySpec = AST.Function (mkVHDLExtId copyId) [AST.IfaceVarDec nPar naturalTM,
292 AST.IfaceVarDec aPar elemTM ] vectorTM
293 -- variable res : fsvec_x (0 to n-1) := (others => a);
296 (AST.SubtypeIn vectorTM
297 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
298 [AST.ToRange (AST.PrimLit "0")
299 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
300 (AST.PrimLit "1")) ]))
301 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
302 (AST.PrimName $ AST.NSimple aPar)])
304 copyExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)