in
return [out_assign]
-
+genConcat :: BuiltinBuilder
+genConcat = genVarArgs genConcat'
+genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genConcat' (Left res) f args@[arg] =
+ let
+ -- Setup the generate scheme
+ len1 = (tfvec_len . Var.varType) arg
+ (_, nvec) = splitAppTy (Var.varType arg)
+ len2 = tfvec_len nvec
+ -- TODO: Use something better than varToString
+ label = mkVHDLExtId ("concatVector" ++ (varToString res))
+ n_id = mkVHDLBasicId "n"
+ n_expr = idToVHDLExpr n_id
+ fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)
+ genScheme = AST.ForGn n_id range
+ -- Create the content of the generate statement: Applying the mapped_f to
+ -- each of the elements in arg, storing to each element in res
+ toRange = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
+ range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
+ resname = vecSlice fromRange toRange
+ argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
+ out_assign = mkUncondAssign (Right resname) argexpr
+ in
+ -- Return the generate statement
+ return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
+ where
+ vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
+ (AST.ToRange init last))
+
+genIteraten :: BuiltinBuilder
+genIteraten dst f args = genIterate dst f (tail args)
+
+genIterate :: BuiltinBuilder
+genIterate = genIterateOrGenerate True
+
+genGeneraten :: BuiltinBuilder
+genGeneraten dst f args = genGenerate dst f (tail args)
+
+genGenerate :: BuiltinBuilder
+genGenerate = genIterateOrGenerate False
+
+genIterateOrGenerate :: Bool -> BuiltinBuilder
+genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
+genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+-- Special case for an empty input vector, just assign start to res
+genIterateOrGenerate' iter (Left res) _ [app_f, start] | len == 0 = return [mkUncondAssign (Left res) (AST.PrimLit "\"\"")]
+ where len = (tfvec_len . Var.varType) res
+genIterateOrGenerate' iter (Left res) f [app_f, start] = do
+ -- -- evec is (TFVec n), so it still needs an element type
+ -- let (nvec, _) = splitAppTy (Var.varType vec)
+ -- -- Put the type of the start value in nvec, this will be the type of our
+ -- -- temporary vector
+ let tmp_ty = Var.varType res
+ let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
+ tmp_vhdl_ty <- vhdl_ty error_msg tmp_ty
+ -- Setup the generate scheme
+ let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
+ let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
+ let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
+ let gen_scheme = AST.ForGn n_id gen_range
+ -- Make the intermediate vector
+ let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
+ -- Create the generate statement
+ cells <- sequence [genFirstCell, genOtherCell]
+ let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
+ -- Assign tmp[len-1] or tmp[0] to res
+ let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name
+ let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
+ return [AST.CSBSm block]
+ where
+ -- The vector length
+ len = (tfvec_len . Var.varType) res
+ -- An id for the counter
+ n_id = mkVHDLBasicId "n"
+ n_cur = idToVHDLExpr n_id
+ -- An expression for previous n
+ n_prev = n_cur AST.:-: (AST.PrimLit "1")
+ -- An expression for len-1
+ len_min_expr = (AST.PrimLit $ show (len-1))
+ -- An id for the tmp result vector
+ tmp_id = mkVHDLBasicId "tmp"
+ tmp_name = AST.NSimple tmp_id
+ -- Generate parts of the fold
+ genFirstCell, genOtherCell :: VHDLSession AST.GenerateSm
+ genFirstCell = do
+ let cond_label = mkVHDLExtId "firstcell"
+ -- if n == 0 or n == len-1
+ let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
+ -- Output to tmp[current n]
+ let resname = mkIndexedName tmp_name n_cur
+ -- Input from start
+ let argexpr = varToVHDLExpr start
+ let startassign = mkUncondAssign (Right resname) argexpr
+ app_concsms <- genApplication (Right resname) app_f [Right argexpr]
+ -- Return the conditional generate part
+ return $ AST.GenerateSm cond_label cond_scheme [] (if iter then
+ [startassign]
+ else
+ app_concsms
+ )
+
+ genOtherCell = do
+ let cond_label = mkVHDLExtId "othercell"
+ -- if n > 0 or n < len-1
+ let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
+ -- Output to tmp[current n]
+ let resname = mkIndexedName tmp_name n_cur
+ -- Input from tmp[previous n]
+ let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
+ app_concsms <- genApplication (Right resname) app_f [Right argexpr]
+ -- Return the conditional generate part
+ return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
+
-----------------------------------------------------------------------------
-- Function to generate VHDL for applications
, (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
, (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
, (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
+ , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
]
where
ixPar = AST.unsafeVHDLBasicId "ix"
(AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
[Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
rotrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
+ reverseVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+ (AST.PrimLit "1")) ]))
+ Nothing
+ -- for i in 0 to res'range loop
+ -- res(vec'length-i-1) := vec(i);
+ -- end loop;
+ reverseFor =
+ AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) rangeId Nothing) [reverseAssign]
+ -- res(vec'length-i-1) := vec(i);
+ reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
+ (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
+ [AST.PrimName $ AST.NSimple iId]))
+ where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
+ (mkVHDLBasicId lengthId) Nothing) AST.:-:
+ AST.PrimName (AST.NSimple iId) AST.:-:
+ (AST.PrimLit "1")
+ -- return res;
+ reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
+
-----------------------------------------------------------------------------
-- A table of builtin functions
-----------------------------------------------------------------------------
, (shiftrId , (2, genFCall ) )
, (rotlId , (1, genFCall ) )
, (rotrId , (1, genFCall ) )
+ , (concatId , (1, genConcat ) )
+ , (reverseId , (1, genFCall ) )
+ , (iteratenId , (3, genIteraten ) )
+ , (iterateId , (2, genIterate ) )
+ , (generatenId , (3, genGeneraten ) )
+ , (generateId , (2, genGenerate ) )
, (emptyId , (0, genFCall ) )
, (singletonId , (1, genFCall ) )
, (copynId , (2, genFCall ) )
Just (ty_id, ty_def) -> do
-- TODO: Check name uniqueness
modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
+ modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
return ty_id
Nothing -> error $ msg ++ "\nVHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
let name = Name.getOccString (TyCon.tyConName tycon)
case name of
"TFVec" -> do
- res <- mk_vector_ty (tfvec_len ty) (tfvec_elem ty)
+ res <- mk_vector_ty ty
return $ Just $ (Arrow.second Right) res
-- "SizedWord" -> do
-- res <- mk_vector_ty (sized_word_len ty) ty
-- | Create a VHDL vector type
mk_vector_ty ::
- Int -- ^ The length of the vector
- -> Type.Type -- ^ The Haskell element type of the Vector
+ Type.Type -- ^ The Haskell type of the Vector
-> VHDLSession (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
-mk_vector_ty len el_ty = do
- elem_types_map <- getA vsElemTypes
+mk_vector_ty ty = do
+ types_map <- getA vsTypes
+ let (nvec_l, nvec_el) = Type.splitAppTy ty
+ let (nvec, leng) = Type.splitAppTy nvec_l
+ let vec_ty = Type.mkAppTy nvec nvec_el
+ let len = tfvec_len ty
+ let el_ty = tfvec_elem ty
let error_msg = "\nVHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty
el_ty_tm <- vhdl_ty error_msg el_ty
let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
- let existing_elem_ty = (fmap fst) $ Map.lookup (OrdType el_ty) elem_types_map
+ let existing_elem_ty = (fmap fst) $ Map.lookup (OrdType vec_ty) types_map
case existing_elem_ty of
Just t -> do
let ty_def = AST.SubtypeIn t (Just range)
Nothing -> do
let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
- modA vsElemTypes (Map.insert (OrdType el_ty) (vec_id, vec_def))
- --modA vsTypeFuns (Map.insert (OrdType el_ty) (genUnconsVectorFuns el_ty_tm vec_id))
+ modA vsTypes (Map.insert (OrdType vec_ty) (vec_id, (Left vec_def)))
+ modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
let ty_def = AST.SubtypeIn vec_id (Just range)
return (ty_id, ty_def)
case Map.lookup (OrdType ty) types of
Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
_ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
+
+mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
+mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
+mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
projects / matthijs / master-project / cλash.git / commitdiff