where
args = case Type.splitTyConApp_maybe ty of
Just (tycon, args) -> args
- Nothing -> error $ "CoreTools.tfvec_len Not a vector type: " ++ (pprString ty)
+ Nothing -> error $ "\nCoreTools.tfvec_len: Not a vector type: " ++ (pprString ty)
[len, el_ty] = args
-- | Get the element type of a TFVec type
where
args = case Type.splitTyConApp_maybe ty of
Just (tycon, args) -> args
- Nothing -> error $ "CoreTools.tfvec_len Not a vector type: " ++ (pprString ty)
+ Nothing -> error $ "\nCoreTools.tfvec_len: Not a vector type: " ++ (pprString ty)
[len, el_ty] = args
-- Is this a wild binder?
-- simple Var CoreExprs, not complexer ones.
exprToVar :: CoreSyn.CoreExpr -> Var.Id
exprToVar (CoreSyn.Var id) = id
-exprToVar expr = error $ "CoreTools.exprToVar Not a var: " ++ show expr
+exprToVar expr = error $ "\nCoreTools.exprToVar: Not a var: " ++ show expr
-- Removes all the type and dictionary arguments from the given argument list,
-- leaving only the normal value arguments. The type given is the type of the
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))
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)
Just body -> do
modA vsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, 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
then
-- This should really only happen at the top level... TODO: Give
-- a different error if this happens down in the recursion.
- error $ "Function " ++ show bndr ++ " is polymorphic, can't normalize"
+ error $ "\nNormalize.normalizeBind: Function " ++ show bndr ++ " is polymorphic, can't normalize"
else do
normalized_funcs <- getA tsNormalized
-- See if this function was normalized already
return ()
-- We don't have a value for this binder. This really shouldn't
-- happen for local id's...
- Nothing -> error $ "No value found for binder " ++ pprString bndr ++ "? This should not happen!"
+ Nothing -> error $ "\nNormalize.normalizeBind: No value found for binder " ++ pprString bndr ++ "? This should not happen!"
expr' <- trans expr
return $ Cast expr' ty
-subeverywhere trans expr = error $ "NormalizeTools.subeverywhere Unsupported expression: " ++ show expr
+subeverywhere trans expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr
-- Apply the given transformation to all expressions, except for direct
-- arguments of an application
-- Assume the bndr has a valid VHDL id already
id = varToVHDLId bndr
ty = Var.varType bndr
+ error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr
in do
- type_mark <- vhdl_ty ty
+ type_mark <- vhdl_ty error_msg ty
return (id, type_mark)
)
createArchitecture (fname, expr) = do
signaturemap <- getA vsSignatures
let signature = Maybe.fromMaybe
- (error $ "Generating architecture for function " ++ (pprString fname) ++ "without signature? This should not happen!")
+ (error $ "\nVHDL.createArchitecture: Generating architecture for function \n" ++ (pprString fname) ++ "\nwithout signature? This should not happen!")
(Map.lookup fname signaturemap)
let entity_id = ent_id signature
-- Strip off lambda's, these will be arguments
mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
mkSigDec bndr =
if True then do --isInternalSigUse use || isStateSigUse use then do
- type_mark <- vhdl_ty $ Var.varType bndr
+ let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
+ type_mark <- (vhdl_ty error_msg) $ Var.varType bndr
return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
else
return Nothing
let sel_name = mkSelectedName (varToVHDLName scrut) label
let sel_expr = AST.PrimName sel_name
return [mkUncondAssign (Left bndr) sel_expr]
- Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
+ Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
- _ -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
+ _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
-- Multiple case alt are be conditional assignments and have only wild
-- binders in the alts and only variables in the case values and a variable
false_expr = (varToVHDLExpr false)
in
return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
-mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
-mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
-mkConcSm (bndr, expr) = error $ "VHDL.mkConcSM Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
+mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
+mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
+mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
-altconToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
-altconToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
+altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
+altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
-- Turn a datacon (without arguments!) into a VHDL expression.
dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
]
-- Translate a Haskell type to a VHDL type, generating a new type if needed.
-vhdl_ty :: Type.Type -> VHDLSession AST.TypeMark
-vhdl_ty ty = do
+vhdl_ty :: String -> Type.Type -> VHDLSession AST.TypeMark
+vhdl_ty msg ty = do
typemap <- getA vsTypes
let builtin_ty = do -- See if this is a tycon and lookup its name
(tycon, args) <- Type.splitTyConApp_maybe ty
Just t -> return t
-- No type yet, try to construct it
Nothing -> do
- newty_maybe <- (construct_vhdl_ty ty)
+ newty_maybe <- (construct_vhdl_ty msg ty)
case newty_maybe of
Just (ty_id, ty_def) -> do
-- TODO: Check name uniqueness
modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
return ty_id
- Nothing -> error $ "Unsupported Haskell type: " ++ pprString ty
+ Nothing -> error $ msg ++ "\nVHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
-- Construct a new VHDL type for the given Haskell type.
-construct_vhdl_ty :: Type.Type -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
-construct_vhdl_ty ty = do
+construct_vhdl_ty :: String -> Type.Type -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+construct_vhdl_ty msg ty = do
case Type.splitTyConApp_maybe ty of
Just (tycon, args) -> do
let name = Name.getOccString (TyCon.tyConName tycon)
res <- mk_natural_ty 0 (ranged_word_bound ty)
return $ Just $ (Arrow.second Right) res
-- Create a custom type from this tycon
- otherwise -> mk_tycon_ty tycon args
+ otherwise -> mk_tycon_ty msg tycon args
Nothing -> return $ Nothing
-- | Create VHDL type for a custom tycon
-mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
-mk_tycon_ty tycon args =
+mk_tycon_ty :: String -> TyCon.TyCon -> [Type.Type] -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+mk_tycon_ty msg tycon args =
case TyCon.tyConDataCons tycon of
-- Not an algebraic type
- [] -> error $ "Only custom algebraic types are supported: " ++ pprString tycon
+ [] -> error $ "\nVHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon
[dc] -> do
let arg_tys = DataCon.dataConRepArgTys dc
-- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
-- violation? Or does it only mean not to apply it again to the same
-- subject?
let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
- elem_tys <- mapM vhdl_ty real_arg_tys
+ let error_msg = msg ++ "\nVHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for one of the arguments."
+ elem_tys <- mapM (vhdl_ty error_msg) real_arg_tys
let elems = zipWith AST.ElementDec recordlabels elem_tys
-- For a single construct datatype, build a record with one field for
-- each argument.
let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
let ty_def = AST.TDR $ AST.RecordTypeDef elems
return $ Just (ty_id, Left ty_def)
- dcs -> error $ "Only single constructor datatypes supported: " ++ pprString tycon
+ dcs -> error $ "\nVHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon
where
-- Create a subst that instantiates all types passed to the tycon
-- TODO: I'm not 100% sure that this is the right way to do this. It seems
mk_vector_ty len el_ty = do
elem_types_map <- getA vsElemTypes
- el_ty_tm <- vhdl_ty el_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
getFieldLabels :: Type.Type -> VHDLSession [AST.VHDLId]
getFieldLabels ty = do
-- Ensure that the type is generated (but throw away it's VHDLId)
- vhdl_ty ty
+ let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
+ vhdl_ty error_msg ty
-- Get the types map, lookup and unpack the VHDL TypeDef
types <- getA vsTypes
case Map.lookup (OrdType ty) types of
Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
- _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty)
+ _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
projects / matthijs / master-project / cλash.git / commitdiff