From: Christiaan Baaij Date: Tue, 30 Jun 2009 11:28:41 +0000 (+0200) Subject: Updated all error messages to include modulename and function name X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=ce7380ad772e2a81c0329c6ee495e18fa0a62280;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Updated all error messages to include modulename and function name --- diff --git a/CoreTools.hs b/CoreTools.hs index 33a4a62..0297f90 100644 --- a/CoreTools.hs +++ b/CoreTools.hs @@ -98,7 +98,7 @@ tfvec_len ty = 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 @@ -107,7 +107,7 @@ tfvec_elem ty = el_ty 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? @@ -165,7 +165,7 @@ has_free_vars = not . VarSet.isEmptyVarSet . CoreFVs.exprFreeVars -- 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 diff --git a/Generate.hs b/Generate.hs index f049d40..1458919 100644 --- a/Generate.hs +++ b/Generate.hs @@ -80,7 +80,7 @@ genFCall' (Left res) f args = do 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 @@ -110,7 +110,7 @@ genMap (Left res) f [Left mapped_f, Left (Var arg)] = -- 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' @@ -154,7 +154,8 @@ genFold' left (Left res) f [folded_f, start, vec] = do -- 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)) @@ -314,7 +315,7 @@ genApplication dst f args = 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 @@ -326,15 +327,15 @@ genApplication dst f args = 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 @@ -343,7 +344,7 @@ genApplication dst f args = 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. @@ -353,7 +354,8 @@ genApplication dst f args = -- 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) @@ -368,7 +370,7 @@ vectorFunId el_ty fname = do 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 diff --git a/Normalize.hs b/Normalize.hs index ee5ea8b..e0591a8 100644 --- a/Normalize.hs +++ b/Normalize.hs @@ -503,7 +503,7 @@ normalizeBind bndr = 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 @@ -537,4 +537,4 @@ normalizeBind bndr = 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!" diff --git a/NormalizeTools.hs b/NormalizeTools.hs index f016cfa..4eedb15 100644 --- a/NormalizeTools.hs +++ b/NormalizeTools.hs @@ -156,7 +156,7 @@ subeverywhere trans (Cast expr ty) = do 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 diff --git a/VHDL.hs b/VHDL.hs index 8bc67a3..289ecf5 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -129,8 +129,9 @@ createEntity (fname, expr) = do -- 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) ) @@ -176,7 +177,7 @@ createArchitecture :: 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 @@ -239,7 +240,8 @@ getSignalId info = 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 @@ -278,9 +280,9 @@ mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) = 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 @@ -293,6 +295,6 @@ mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) 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 diff --git a/VHDLTools.hs b/VHDLTools.hs index 0979639..06aec7f 100644 --- a/VHDLTools.hs +++ b/VHDLTools.hs @@ -157,8 +157,8 @@ exprToVHDLExpr = varToVHDLExpr . exprToVar 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 @@ -262,8 +262,8 @@ builtin_types = ] -- 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 @@ -276,17 +276,17 @@ vhdl_ty ty = do 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) @@ -301,22 +301,23 @@ construct_vhdl_ty ty = do 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. @@ -326,7 +327,7 @@ mk_tycon_ty tycon args = 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 @@ -344,7 +345,8 @@ mk_vector_ty :: 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 @@ -375,9 +377,10 @@ mk_natural_ty min_bound max_bound = do 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)