id <- vectorFunId el_ty fname
return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $
map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
-genFCall' (Right name) _ _ = error $ "Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+genFCall' (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
-- | Generate a generate statement for the builtin function "map"
genMap :: BuiltinBuilder
-- Return the generate statement
return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
-genMap' (Right name) _ _ = error $ "Cannot generate map function call assigned to a VHDLName: " ++ show name
+genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
genZipWith :: BuiltinBuilder
genZipWith = genVarArgs genZipWith'
-- Put the type of the start value in nvec, this will be the type of our
-- temporary vector
let tmp_ty = Type.mkAppTy nvec (Var.varType start)
- tmp_vhdl_ty <- vhdl_ty tmp_ty
+ 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 ("foldlVector" ++ (varToString vec))
let block_label = mkVHDLExtId ("foldlVector" ++ (varToString start))
-- Return the generate functions
return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
+genCopy :: BuiltinBuilder
+genCopy = genVarArgs genCopy'
+genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genCopy' (Left res) f args@[arg] =
+ let
+ resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others)
+ (AST.PrimName $ (varToVHDLName arg))]
+ out_assign = mkUncondAssign (Left res) resExpr
+ in
+ return [out_assign]
+
+
+
-----------------------------------------------------------------------------
-- Function to generate VHDL for applications
-----------------------------------------------------------------------------
mkassign label arg =
let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
mkUncondAssign (Right sel_name) arg
- Right _ -> error $ "Generate.genApplication Can't generate dataconstructor application without an original binder"
+ Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder"
IdInfo.VanillaGlobal -> do
-- It's a global value imported from elsewhere. These can be builtin
-- functions. Look up the function name in the name table and execute
if length args == arg_count then
builder dst f args
else
- error $ "Generate.genApplication Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
- Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
+ error $ "\nGenerate.genApplication: Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
+ Nothing -> error $ "\nGenerate.genApplication: Using function from another module that is not a known builtin: " ++ pprString f
IdInfo.NotGlobalId -> do
signatures <- getA vsSignatures
-- This is a local id, so it should be a function whose definition we
-- have and which can be turned into a component instantiation.
let
signature = Maybe.fromMaybe
- (error $ "Using function '" ++ (varToString f) ++ "' without signature? This should not happen!")
+ (error $ "\nGenerate.genApplication: Using function '" ++ (varToString f) ++ "' without signature? This should not happen!")
(Map.lookup f signatures)
entity_id = ent_id signature
-- TODO: Using show here isn't really pretty, but we'll need some
portmaps = mkAssocElems (map (either exprToVHDLExpr id) args) ((either varToVHDLName id) dst) signature
in
return [mkComponentInst label entity_id portmaps]
- details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
+ details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
-----------------------------------------------------------------------------
-- Functions to generate functions dealing with vectors.
-- element type. Generates -- this function if needed.
vectorFunId :: Type.Type -> String -> VHDLSession AST.VHDLId
vectorFunId el_ty fname = do
- elemTM <- vhdl_ty el_ty
+ let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
+ elemTM <- vhdl_ty error_msg el_ty
-- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
-- the VHDLState or something.
let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
let functions = genUnconsVectorFuns elemTM vectorTM
case lookup fname functions of
Just body -> do
- modA vsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, body)
+ modA vsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, (fst body))
+ mapM_ (vectorFunId el_ty) (snd body)
return function_id
- Nothing -> error $ "I don't know how to generate vector function " ++ fname
+ Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
where
function_id = mkVHDLExtId fname
genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
-> AST.TypeMark -- ^ type of the vector
- -> [(String, AST.SubProgBody)]
+ -> [(String, (AST.SubProgBody, [String]))]
genUnconsVectorFuns elemTM vectorTM =
- [ (exId, AST.SubProgBody exSpec [] [exExpr])
- , (replaceId, AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet])
- , (headId, AST.SubProgBody headSpec [] [headExpr])
- , (lastId, AST.SubProgBody lastSpec [] [lastExpr])
- , (initId, AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet])
- , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet])
- , (takeId, AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet])
- , (dropId, AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet])
- , (plusgtId, AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet])
- , (emptyId, AST.SubProgBody emptySpec [AST.SPCD emptyVar] [emptyExpr])
- , (singletonId, AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet])
- , (copyId, AST.SubProgBody copySpec [AST.SPVD copyVar] [copyExpr])
- , (selId, AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet])
- , (ltplusId, AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet] )
- , (plusplusId, AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet])
+ [ (exId, (AST.SubProgBody exSpec [] [exExpr],[]))
+ , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet],[]))
+ , (headId, (AST.SubProgBody headSpec [] [headExpr],[]))
+ , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[]))
+ , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[]))
+ , (tailId, (AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet],[]))
+ , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[]))
+ , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[]))
+ , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
+ , (emptyId, (AST.SubProgBody emptySpec [AST.SPCD emptyVar] [emptyExpr],[]))
+ , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
+ , (copynId, (AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr],[]))
+ , (selId, (AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet],[]))
+ , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
+ , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
+ , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
+ , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
+ , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
+ , (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]))
]
where
ixPar = AST.unsafeVHDLBasicId "ix"
(Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
(AST.PrimName $ AST.NSimple aPar)])
singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- copySpec = AST.Function (mkVHDLExtId copyId) [AST.IfaceVarDec nPar naturalTM,
+ copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar naturalTM,
AST.IfaceVarDec aPar elemTM ] vectorTM
-- variable res : fsvec_x (0 to n-1) := (others => a);
- copyVar =
+ copynVar =
AST.VarDec resId
(AST.SubtypeIn vectorTM
(Just $ AST.ConstraintIndex $ AST.IndexConstraint
(Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
(AST.PrimName $ AST.NSimple aPar)])
-- return res
- copyExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM,
AST.IfaceVarDec sPar naturalTM,
AST.IfaceVarDec nPar naturalTM,
((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
(AST.PrimName $ AST.NSimple vec2Par))
plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
-
+ lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
+ lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))
+ shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
+ AST.IfaceVarDec aPar elemTM ] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-1);
+ shiftlVar =
+ 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
+ -- res := a & init(vec)
+ shiftlExpr = AST.NSimple resId AST.:=
+ (AST.PrimName (AST.NSimple aPar) AST.:&:
+ (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
+ shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
+ AST.IfaceVarDec aPar elemTM ] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-1);
+ shiftrVar =
+ 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
+ -- res := tail(vec) & a
+ shiftrExpr = AST.NSimple resId AST.:=
+ ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
+ (AST.PrimName (AST.NSimple aPar)))
+
+ shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
+ -- return vec'length = 0
+ nullExpr = AST.ReturnSm (Just $
+ AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:=:
+ AST.PrimLit "0")
+ rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-1);
+ rotlVar =
+ 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
+ -- if null(vec) then res := vec else res := last(vec) & init(vec)
+ rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
+ [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
+ []
+ (Just $ AST.Else [rotlExprRet])
+ where rotlExprRet =
+ AST.NSimple resId AST.:=
+ ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
+ (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
+ rotlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-1);
+ rotrVar =
+ 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
+ -- if null(vec) then res := vec else res := tail(vec) & head(vec)
+ rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
+ [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
+ []
+ (Just $ AST.Else [rotrExprRet])
+ where rotrExprRet =
+ AST.NSimple resId AST.:=
+ ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
+ (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)
-----------------------------------------------------------------------------
-- A table of builtin functions
-----------------------------------------------------------------------------
, (foldrId , (3, genFoldr ) )
, (zipId , (2, genZip ) )
, (unzipId , (1, genUnzip ) )
+ , (shiftlId , (2, genFCall ) )
+ , (shiftrId , (2, genFCall ) )
+ , (rotlId , (1, genFCall ) )
+ , (rotrId , (1, genFCall ) )
, (emptyId , (0, genFCall ) )
, (singletonId , (1, genFCall ) )
- , (copyId , (2, genFCall ) )
+ , (copynId , (2, genFCall ) )
+ , (copyId , (1, genCopy ) )
+ , (lengthTId , (1, genFCall ) )
+ , (nullId , (1, genFCall ) )
, (hwxorId , (2, genOperator2 AST.Xor ) )
, (hwandId , (2, genOperator2 AST.And ) )
, (hworId , (2, genOperator2 AST.Or ) )
projects / matthijs / master-project / cλash.git / blobdiff