From 915f5b9eca79f1dea44bff9a58736a3add1e19c0 Mon Sep 17 00:00:00 2001 From: Julie Schwartz Date: Tue, 1 Aug 2023 22:43:21 +1200 Subject: [PATCH 1/4] Add examples for GitHub issue 584 --- .../IncludeVendor_MissingCloseDelim.bsv | 4 ++ .../bsc.preprocessor/include/include.exp | 5 +++ .../misc/Define_NonTermComment_EOF.bsv | 1 + .../misc/FuncMacro_MissingParen.bsv | 6 +++ .../misc/FuncMacro_MissingParen_EOF.bsv | 2 + .../misc/FuncMacro_MissingParen_NextLine.bsv | 7 ++++ .../misc/Line_BadArg_NonNumeric.bsv | 5 +++ .../misc/Line_BadArg_NumericWithSpace.bsv | 5 +++ .../bsc.preprocessor/misc/Line_MissingArg.bsv | 6 +++ .../misc/Line_MissingArg_EOF.bsv | 3 ++ .../misc/Line_MissingArg_NextLine.bsv | 7 ++++ .../misc/Line_MissingArg_NoNext.bsv | 5 +++ .../misc/Line_MissingParen.bsv | 5 +++ .../misc/Line_MissingParen_EOF.bsv | 3 ++ .../misc/Line_MissingParen_NextLine.bsv | 6 +++ testsuite/bsc.preprocessor/misc/misc.exp | 41 +++++++++++++++++++ 16 files changed, 111 insertions(+) create mode 100644 testsuite/bsc.preprocessor/include/IncludeVendor_MissingCloseDelim.bsv create mode 100644 testsuite/bsc.preprocessor/misc/Define_NonTermComment_EOF.bsv create mode 100644 testsuite/bsc.preprocessor/misc/FuncMacro_MissingParen.bsv create mode 100644 testsuite/bsc.preprocessor/misc/FuncMacro_MissingParen_EOF.bsv create mode 100644 testsuite/bsc.preprocessor/misc/FuncMacro_MissingParen_NextLine.bsv create mode 100644 testsuite/bsc.preprocessor/misc/Line_BadArg_NonNumeric.bsv create mode 100644 testsuite/bsc.preprocessor/misc/Line_BadArg_NumericWithSpace.bsv create mode 100644 testsuite/bsc.preprocessor/misc/Line_MissingArg.bsv create mode 100644 testsuite/bsc.preprocessor/misc/Line_MissingArg_EOF.bsv create mode 100644 testsuite/bsc.preprocessor/misc/Line_MissingArg_NextLine.bsv create mode 100644 testsuite/bsc.preprocessor/misc/Line_MissingArg_NoNext.bsv create mode 100644 testsuite/bsc.preprocessor/misc/Line_MissingParen.bsv create mode 100644 testsuite/bsc.preprocessor/misc/Line_MissingParen_EOF.bsv create mode 100644 testsuite/bsc.preprocessor/misc/Line_MissingParen_NextLine.bsv diff --git a/testsuite/bsc.preprocessor/include/IncludeVendor_MissingCloseDelim.bsv b/testsuite/bsc.preprocessor/include/IncludeVendor_MissingCloseDelim.bsv new file mode 100644 index 000000000..825fed226 --- /dev/null +++ b/testsuite/bsc.preprocessor/include/IncludeVendor_MissingCloseDelim.bsv @@ -0,0 +1,4 @@ +`include Date: Wed, 2 Aug 2023 19:48:50 +1200 Subject: [PATCH 2/4] Resolve incomplete pattern warnings, with GHC 9.2+ This resolves most but not all warnings. See GitHub issue 469. --- src/comp/AAddScheduleDefs.hs | 10 +-- src/comp/ACheck.hs | 5 +- src/comp/AConv.hs | 8 ++- src/comp/AOpt.hs | 11 ++- src/comp/ASchedule.hs | 18 ++--- src/comp/AState.hs | 5 +- src/comp/ASyntax.hs | 6 +- src/comp/AVeriQuirks.hs | 5 +- src/comp/AVerilog.hs | 3 +- src/comp/CCSyntax.hs | 5 +- src/comp/CSyntax.hs | 4 +- src/comp/CVPrint.hs | 6 +- src/comp/Depend.hs | 5 +- src/comp/Deriving.hs | 59 +++++++++------ src/comp/GenWrap.hs | 30 +++++--- src/comp/GraphMap.hs | 8 +-- src/comp/IConv.hs | 36 +++++++--- src/comp/IExpand.hs | 16 +++-- src/comp/ISimplify.hs | 6 +- src/comp/ISyntaxUtil.hs | 56 +++++++-------- src/comp/ITransform.hs | 77 ++++++++++---------- src/comp/Id.hs | 9 ++- src/comp/MakeSymTab.hs | 6 +- src/comp/PPrint.hs | 11 +-- src/comp/Parser/BSV/CVParser.lhs | 17 +++-- src/comp/Parser/BSV/CVParserAssertion.lhs | 16 +++-- src/comp/Parser/BSV/CVParserCommon.lhs | 14 ++-- src/comp/Parser/BSV/CVParserImperative.lhs | 83 +++++++++++----------- src/comp/Parser/Classic/CParser.hs | 14 ++-- src/comp/PreIds.hs | 13 +++- src/comp/SAL.hs | 5 +- src/comp/SimCCBlock.hs | 18 +++-- src/comp/SimCOpt.hs | 7 +- src/comp/SimExpand.hs | 5 +- src/comp/SimPrimitiveModules.hs | 27 +++---- src/comp/StdPrel.hs | 4 +- src/comp/Synthesize.hs | 10 ++- src/comp/SystemVerilogPreprocess.lhs | 68 ++++++++++-------- src/comp/SystemVerilogScanner.lhs | 12 +++- src/comp/TCheck.hs | 38 ++++++---- src/comp/Util.hs | 19 ++++- src/comp/VCD.hs | 7 +- src/comp/bluetcl.hs | 3 +- src/comp/bsc.hs | 5 +- src/comp/showrules.hs | 10 +-- src/comp/vcdcheck.hs | 2 +- testsuite/bsc.preprocessor/misc/misc.exp | 2 +- 47 files changed, 472 insertions(+), 332 deletions(-) diff --git a/src/comp/AAddScheduleDefs.hs b/src/comp/AAddScheduleDefs.hs index 4e5a11fec..44449a2ed 100644 --- a/src/comp/AAddScheduleDefs.hs +++ b/src/comp/AAddScheduleDefs.hs @@ -21,7 +21,7 @@ import PreIds(id_write) import qualified Data.Map as M import Data.List(intersect) -import Data.Maybe(isJust, fromJust, fromMaybe, maybeToList, mapMaybe) +import Data.Maybe(fromJust, fromMaybe, maybeToList, mapMaybe) -- import Debug.Trace @@ -110,10 +110,10 @@ aAddScheduleDefs flags pps pkg aschedinfo = , isRdyId (aIfaceName m) ] pre_en_map = M.fromList $ - map (\(n,Just e) -> (n,e)) - (filter (isJust . snd) - [ (aIfaceName m, getMethodEnExpr m) - | m <- ifc0 ]) + [ (aIfaceName m, e) + | m <- ifc0 + , (Just e) <- [getMethodEnExpr m] + ] (rdy_map, rdy_proof_obs) = handleAlwaysReady (unsafeAlwaysRdy flags) pkgpos pps pre_rdy_map (en_map, enrdy_proof_obs) = diff --git a/src/comp/ACheck.hs b/src/comp/ACheck.hs index f4f34e12c..f42553812 100644 --- a/src/comp/ACheck.hs +++ b/src/comp/ACheck.hs @@ -109,7 +109,7 @@ chkAIface aa@(AIInout { aif_inout = r }) = tracePP "chkAIface AIInout" aa $ chkAInout r chkCond :: AType -> Bool -chkCond t = isBit t && (let (ATBit sz) = t in (sz == 1)) +chkCond = isBit1 chkAAction :: AAction -> Bool chkAAction aa@(ACall i m (c:es)) = @@ -319,7 +319,8 @@ isBit (ATBit _) = True isBit _ = False isBit1 :: AType -> Bool -isBit1 t = isBit t && (aSize t == 1) +isBit1 (ATBit sz) = (sz == 1) +isBit1 _ = False isString :: AType -> Bool isString (ATString _) = True diff --git a/src/comp/AConv.hs b/src/comp/AConv.hs index 8b6aa158f..a1b8d1849 100644 --- a/src/comp/AConv.hs +++ b/src/comp/AConv.hs @@ -519,7 +519,7 @@ aExpr e@(IAps (ICon m (ICSel { })) _ Nothing -> internalError ("aExpr: avValue_ on ICForeign without fcallNo") Just val -> val - t@(ATBit _) = aTypeConvE e (iGetType e) + t = aTypeConvE e (iGetType e) in return (ATaskValue t i name isC n) @@ -534,7 +534,7 @@ aExpr e@(IAps (ICon m (ICSel { })) _ Nothing -> internalError ("aExpr: avValue_ on ICForeign without fcallNo") Just val -> val - t@(ATBit _) = aTypeConvE e (iGetType e) + t = aTypeConvE e (iGetType e) in -- the value side carries no arguments -- the cookie "n" will connect it back up to the action side @@ -966,4 +966,6 @@ eTrunc errh n e = then let e' = IAps (icSelect noPosition) [ITNum n, ITNum 0, ITNum k] [e] in fst (iTransExpr errh e') else e - where ATBit k = aTypeConvE e (iGetType e) + where k = case aTypeConvE e (iGetType e) of + ATBit sz -> sz + _ -> internalError "AConv.eTrunc: unexpected type" diff --git a/src/comp/AOpt.hs b/src/comp/AOpt.hs index 6f0da24a7..869529552 100644 --- a/src/comp/AOpt.hs +++ b/src/comp/AOpt.hs @@ -18,7 +18,7 @@ import qualified Data.Map as M import qualified Data.Set as S import Util(allSame, flattenPairs, makePairs, remOrdDup, integerToBits, itos, eqSnd, cmpSnd, nubByFst, map_insertManyWith, - headOrErr, initOrErr, lastOrErr) + headOrErr, initOrErr, lastOrErr, unconsOrErr) import IntegerUtil(integerSelect) import PPrint import IntLit @@ -1003,10 +1003,9 @@ collIf findf v ces d = collIfPrim :: (AId -> AExpr) -> AExpr -> [(AExpr, AExpr)] -> AExpr -> Maybe ([(AExpr, AExpr)], AExpr) collIfPrim findf v ces (APrim _ _ PrimIf [_, t, e]) | t == e = Just $ collIf findf v ces t -collIfPrim findf v ces (APrim _ _ PrimIf [cond, t, e]) | me /= Nothing = +collIfPrim findf v ces (APrim _ _ PrimIf [cond, t, e]) + | (Just cs) <- getConsts findf (== v) cond = Just $ collIf findf v (zip (map snd cs) (repeat t) ++ ces) e - where me = getConsts findf (== v) cond - Just cs = me collIfPrim findf v ces (APrim _ _ PrimCase (v':d:ces')) | v == v' = Just (reverse ces ++ makePairs ces', d) collIfPrim _ _ ces d = Nothing @@ -1593,7 +1592,7 @@ optAndOrExpr :: AExpr -> SIO AExpr optAndOrExpr (APrim i t@(ATBit 1) op es) | (op == PrimBAnd) || (op == PrimAnd) = do es1 <- mapM optAndOrExpr es - let (e1:er1) = reverse es1 + let (e1, er1) = unconsOrErr "AOpt.optAndOrExpr And" (reverse es1) es2 <- foldM testBuildAnd [e1] er1 checkIfConst $ case es2 of [e] -> e @@ -1603,7 +1602,7 @@ optAndOrExpr (APrim i t@(ATBit 1) op es) optAndOrExpr (APrim i t@(ATBit 1) op es) | (op == PrimBOr) || (op == PrimOr) = do es1 <- mapM optAndOrExpr es - let (e1:er1) = reverse es1 + let (e1,er1) = unconsOrErr "AOpt.optAndOrExpr Or" (reverse es1) es2 <- foldM testBuildOr [e1] er1 checkIfConst $ case es2 of [e] -> e diff --git a/src/comp/ASchedule.hs b/src/comp/ASchedule.hs index f36917192..a9e6f1b4b 100644 --- a/src/comp/ASchedule.hs +++ b/src/comp/ASchedule.hs @@ -43,7 +43,7 @@ import Error(internalError, EMsg, WMsg, EMsgs(..), ErrMsg(..), showErrorList, showWarningList, getErrMsgTag) import ErrorMonad(ErrorMonad(..)) import PFPrint -import PPrint(vsep) +import PPrint(vsep, commaSep) import SCC(scc,tsort) import Id(Id, emptyId, getIdString, getIdBaseString, getIdPosition, isRdyId, addToBase, mk_homeless_id, mkIdWillFire, addSuffix) @@ -3141,8 +3141,7 @@ makeRuleBetweenEdges ruleBetweenMap ruleMethodUseMap ruleNames sched_id_order = pairs = [ (m1, m2) | let m_methods2 = M.lookup inst r2_usemap, - isJust m_methods2, - let (Just methods2) = m_methods2, + (Just methods2) <- [m_methods2], (methId1, _) <- methods1, (methId2, _) <- methods2, methId1 /= methId2, @@ -4276,11 +4275,8 @@ verifySafeRuleActions flags userDefs rulePCConflictUseMap dtstate = do | otherwise = (True, Just $ text "...") mkArgs es | null es = (False, empty) - | show_all = (False, ppeCommaSep es) + | show_all = (False, commaSep (map ppe es)) | otherwise = (True, text "...") - ppeCommaSep xs = let (y:ys) = reverse (map ppe xs) - ys' = map (<> text ",") ys - in sep $ reverse (y:ys') -- (method, hasCond, args, moreInfo) getUseInfo :: UniqueUse -> (String, Maybe Doc, Doc, Bool) getUseInfo u@(UUExpr (AMethCall _ i m es) _) = @@ -4419,7 +4415,7 @@ verifyStaticScheduleOneRule errh flags gen_backend let m2 = MethodId inst methId2, -- either direction is an error let m_rs = findBetween m1 m2, - isJust m_rs, let Just rs = m_rs ] + (Just rs) <- [m_rs] ] in if (null badPairs) then Nothing else Just (rule, badPairs) @@ -4526,8 +4522,7 @@ verifyStaticScheduleTwoRules errh flags gen_backend moduleId pairs = [ (m1, m2) | let m_methods2 = M.lookup inst r2_usemap, - isJust m_methods2, - let (Just methods2) = m_methods2, + (Just methods2) <- [m_methods2], (methId1, _) <- methods1, (methId2, _) <- methods2, methId1 /= methId2, @@ -5200,8 +5195,7 @@ addAllMEAssumps pragmas rules = addMEAssumps :: [ASchedulePragma] -> ARule -> ARuleId -> [(ARule,(ARuleId,[ARuleId]))] addMEAssumps pragmas r@(ARule { arule_id = rid }) new_id = rs where me_pairs = extractMEPairsSP pragmas - getRule ids = l - where (l:_) = ids + getRule ids = headOrErr "addMEAssumps getRule" ids check_pairs :: [(ARuleId, [([ARuleId],[ARuleId])])] check_pairs = [ ((getRule (as ++ bs)), [(as, bs)]) | (as, bs) <- me_pairs ] check_map = M.fromListWith (++) check_pairs diff --git a/src/comp/AState.hs b/src/comp/AState.hs index 5ce5296ae..513189cf5 100644 --- a/src/comp/AState.hs +++ b/src/comp/AState.hs @@ -917,7 +917,10 @@ mkBlob mMap omMultMap (method@(MethodId obj met), usedPorts) = -- The list of converted uses per port -- (This intermediate step is exposed to make "u" available to "uExp".) - uses@(((u, _):_):_) = map (map cvt) portUses + uses = map (map cvt) portUses + u = case uses of + (((uu, _):_):_) -> uu + _ -> internalError "AState.mkBlob: u" -- Complete the conversion to make a list of MethPortBlob meth_port_blobs :: [MethPortBlob] diff --git a/src/comp/ASyntax.hs b/src/comp/ASyntax.hs index d8c5e8e8a..c28bcd1c8 100644 --- a/src/comp/ASyntax.hs +++ b/src/comp/ASyntax.hs @@ -1600,10 +1600,8 @@ ppeString ds ec = instance (PPrintExpand a) => PPrintExpand [a] where pPrintExpand _ d _ [] = text "[]" - pPrintExpand m d _ xs = let (y:ys) = reverse (map (pPrintExpand m d defContext) xs) - ys' = map (<> text ",") ys - xs' = reverse (y:ys') - in text "[" <> sep xs' <> text "]" + pPrintExpand m d _ xs = let xs' = map (pPrintExpand m d defContext) xs + in text "[" <> commaSep xs' <> text "]" ppeAPackage :: Int -> PDetail -> APackage -> Doc ppeAPackage lim d apkg@(APackage { apkg_local_defs = ds }) = diff --git a/src/comp/AVeriQuirks.hs b/src/comp/AVeriQuirks.hs index a9e29fed0..1648ea516 100644 --- a/src/comp/AVeriQuirks.hs +++ b/src/comp/AVeriQuirks.hs @@ -175,7 +175,10 @@ aQExp :: Bool -> AExpr -> QQState AExpr -- non-constant bit extraction turns into shift and mask aQExp top (APrim aid t@(ATBit n) PrimExtract [e, h, l]) | h /= l && not (isConst h && isConst l) = - let te@(ATBit m) = aType e + let te = aType e + m = case te of + (ATBit sz) -> sz + _ -> internalError "AVeriQuirks.aQExp PrimExtract: unexpected expr type" ht = aType h -- (e & ~(('1 << 1) << h)) e1 = APrim aid te PrimAnd [e, mask] diff --git a/src/comp/AVerilog.hs b/src/comp/AVerilog.hs index 0781bda77..472a02d2a 100644 --- a/src/comp/AVerilog.hs +++ b/src/comp/AVerilog.hs @@ -1719,7 +1719,8 @@ notProbe (_, VMInst (VId string _ _) _ _ _, _) = (string /= "Probe") notProbe item = True count :: (Ord a) => [a] -> [(Int, a)] -count = sort . map (\ xs@(x:_) -> (length xs, x)) . group . sort +count = let getInfo xs = (length xs, headOrErr "count" xs) + in sort . map getInfo . group . sort dropIds :: [VId] -> (AId, VMItem, InstInfo) -> (AId, VMItem, InstInfo) dropIds is (i, vmi, info) = diff --git a/src/comp/CCSyntax.hs b/src/comp/CCSyntax.hs index 1dd1eeb0f..b1428f201 100644 --- a/src/comp/CCSyntax.hs +++ b/src/comp/CCSyntax.hs @@ -835,8 +835,9 @@ userType name v = v `ofType` (CTuserType name) function :: (CCFragment -> CCFragment) -> CCFragment -> [CCFragment] -> CCFragment function retC v args = - let (CTyped retT _) = (retC CAbstract) - in v `ofType` (CTfunction retT args) + case (retC CAbstract) of + (CTyped retT _) -> v `ofType` (CTfunction retT args) + _ -> internalError "CCSyntax function" ctor :: CCFragment -> [CCFragment] -> CCFragment ctor v args = v `ofType` (CTconstructor args) diff --git a/src/comp/CSyntax.hs b/src/comp/CSyntax.hs index 281cf9697..9f43ad839 100644 --- a/src/comp/CSyntax.hs +++ b/src/comp/CSyntax.hs @@ -87,7 +87,7 @@ import CType import VModInfo import Type(tClock, tReset) import Pragma -import Util(itos, log2) +import Util(itos, log2, fromJustOrErr) import Data.Maybe(listToMaybe) import Data.List(genericLength) import FStringCompat @@ -1127,7 +1127,7 @@ instance PPrint CExpr where ---- pPrint d p (CConT _ i es) = pPrint d p (CCon i es) pPrint d p (CStructT ty ies) = pPrint d p (CStruct (Just True) tyc ies) - where (Just tyc) = leftCon ty + where tyc = fromJustOrErr "pPrint CStructT" (leftCon ty) pPrint d p (CSelectT _ i) = text "." <> ppVarId d i pPrint d p (CLitT _ l) = pPrint d p l pPrint d p (CAnyT pos uk t) = text "_" diff --git a/src/comp/CVPrint.hs b/src/comp/CVPrint.hs index 36a34eadd..8f97ace07 100644 --- a/src/comp/CVPrint.hs +++ b/src/comp/CVPrint.hs @@ -70,7 +70,7 @@ import CSyntax import CSyntaxUtil import IntLit import IntegerUtil(integerFormat) -import Util(itos, quote, log2) +import Util(itos, quote, log2, fromJustOrErr, unconsOrErr) -------- @@ -642,7 +642,7 @@ instance PVPrint CExpr where ---- pvPrint d p (CConT _ i es) = pvPrint d p (CCon i es) pvPrint d p (CStructT ty ies) = pvPrint d p (CStruct (Just True) tyc ies) - where (Just tyc) = leftCon ty + where tyc = fromJustOrErr "pvPrint CStructT" (leftCon ty) pvPrint d p (CSelectT _ i) = text "." <> pvpId d i pvPrint d p (CLitT _ l) = pvPrint d p l pvPrint d p (CAnyT pos uk t) = text "?" @@ -1093,7 +1093,7 @@ ppClause d xs (CClause [] mqs e) = <> t";" ppClause d xs (CClause ps [] e) = let ids' = xs ++ map (ppCP d) ps - (i:ids) = if null ids' then internalError "CVPrint.ppClause" else ids' + (i, ids) = unconsOrErr "CVPrint.ppClause" ids' line1 = ppUntypedId d i ids in ppValueSignRest d i [] True False line1 e "function" diff --git a/src/comp/Depend.hs b/src/comp/Depend.hs index 68ec06c1e..da7edcc13 100644 --- a/src/comp/Depend.hs +++ b/src/comp/Depend.hs @@ -86,7 +86,10 @@ chkDeps errh flags name = do ECircularImports (map ppReadable cycle))] Right ns -> do let -- the pkginfo of all depended modules - pis' = [ pi | n <- ns, let Just pi = findInfo n pis ] + pis' = let getInfo n = case findInfo n pis of + Just pi -> pi + _ -> internalError "Depend.chkDeps: pis'" + in map getInfo ns -- names of files resulting from codegen, if we want -- to return them, for a linking stage to use --genfs = concatMap (getGenFs flags) pis' diff --git a/src/comp/Deriving.hs b/src/comp/Deriving.hs index fb39c848b..961f4a192 100644 --- a/src/comp/Deriving.hs +++ b/src/comp/Deriving.hs @@ -1,7 +1,7 @@ module Deriving(derive) where import Data.List(intercalate) -import Util(log2, checkEither, headOrErr, lastOrErr) +import Util(log2, checkEither, headOrErr, lastOrErr, unconsOrErr, fromJustOrErr) import Error(internalError, EMsg, ErrMsg(..), ErrorHandle, bsError) import Flags(Flags) import Position @@ -86,7 +86,9 @@ doDer :: Flags -> SymTab -> Id -> [(Id, CDefn)] -> CDefn -> doDer flags r packageid xs data_decl@(Cdata {}) = let unqual_name = iKName (cd_name data_decl) qual_name = qualId packageid unqual_name - Just (TypeInfo _ kind _ _) = findType r qual_name + kind = case findType r qual_name of + Just (TypeInfo _ k _ _) -> k + _ -> internalError "Deriving.doDer Cdata: findType" ty_var_names = cd_type_vars data_decl ty_var_kinds = getArgKinds kind ty_vars = zipWith cTVarKind ty_var_names ty_var_kinds @@ -98,7 +100,9 @@ doDer flags r packageid xs data_decl@(Cdata {}) = doDer flags r packageid xs struct_decl@(Cstruct _ s i ty_var_names fields derivs) = let unqual_name = iKName i qual_name = qualId packageid unqual_name - Just (TypeInfo _ kind _ _) = findType r qual_name + kind = case findType r qual_name of + Just (TypeInfo _ k _ _) -> k + _ -> internalError "Deriving.doDer Cstruct: findType" ty_var_kinds = getArgKinds kind ty_vars = zipWith cTVarKind ty_var_names ty_var_kinds derivs' = addAutoDerivs flags r qual_name ty_vars derivs @@ -166,19 +170,17 @@ doDataDer r packageid xs i vs ocs cs (CTypeclass di) | qualEq di idGeneric = -- another type, that is it has only one disjunct taking only one argument, -- then inherit the instance from that type. doDataDer _ _ xs i vs [cos@(COriginalSummand { cos_arg_types = [CQType _ ty]})] cs di - | fieldSet `S.isSubsetOf` tvset, - Just (Cclass _ _ _ [v] _ fs) <- lookup (typeclassId di) xs = Right [inst] - where tvset = S.fromList (concatMap tv vs) - fieldType = cos_arg_types cos - fieldSet = S.fromList (tv fieldType) - Just (Cclass _ _ _ [v] _ fs) = lookup (typeclassId di) xs + | fieldSet `S.isSubsetOf` tvset + , Just (Cclass _ _ _ [v] _ fs) <- lookup (typeclassId di) xs + = let ity = foldl TAp (cTCon i) vs inst = Cinstance (CQType [CPred di [ty]] (TAp (cTCon $ typeclassId di) ity)) (map conv fs) conv (CField { cf_name = f, cf_type = CQType _ t }) = CLValue (unQualId f) [CClause [] [] (mkConv con coCon tmpVarXIds tv t (CVar f))] [] - where (Just kind) = getTypeKind t + where kind = fromJustOrErr "Deriving.doDataDer isomorphic: getTypeKind" $ + getTypeKind t tv = cTVarKind v kind cn = getCOSName cos con e = CCon cn [e] @@ -187,6 +189,11 @@ doDataDer _ _ xs i vs [cos@(COriginalSummand { cos_arg_types = [CQType _ ty]})] [CCaseArm { cca_pattern = CPCon cn [CPVar id_y], cca_filters = [], cca_consequent = CVar id_y }] + in + Right [inst] + where tvset = S.fromList (concatMap tv vs) + fieldType = cos_arg_types cos + fieldSet = S.fromList (tv fieldType) doDataDer _ _ _ i vs ocs cs (CTypeclass di) = Left (getPosition di, ECannotDerive (pfpString di)) @@ -209,22 +216,25 @@ doStructDer r packageid _ i vs cs (CTypeclass di) | qualEq di idGeneric = -- If the struct is isomorphic to another type (that is, it as only one -- field, of that other type), then inherit the instance from that type. doStructDer _ _ xs i vs [field] di - | fieldSet `S.isSubsetOf` tvset, - Just (Cclass _ _ _ [v] _ fs) <- lookup (typeclassId di) xs = Right [inst] - where tvset = S.fromList (concatMap tv vs) - fieldType = cf_type field - fieldSet = S.fromList (tv fieldType) - Just (Cclass _ _ _ [v] _ fs) = lookup (typeclassId di) xs + | fieldSet `S.isSubsetOf` tvset + , Just (Cclass _ _ _ [v] _ fs) <- lookup (typeclassId di) xs + = let ity = foldl TAp (cTCon i) vs CQType _ type_no_qual = fieldType inst = Cinstance (CQType [CPred di [type_no_qual]] (TAp (cTCon $ typeclassId di) ity)) (map conv fs) conv (CField { cf_name = f, cf_type = CQType _ t }) = CLValue (unQualId f) [CClause [] [] (mkConv con coCon tmpVarXIds tv t (CVar f))] [] - where (Just kind) = getTypeKind t + where kind = fromJustOrErr "Deriving.doStructDer isomorphic: getTypeKind" $ + getTypeKind t tv = cTVarKind v kind con e = CStruct (Just True) i [(cf_name field, e)] coCon e = CSelectTT i e (cf_name field) + in + Right [inst] + where tvset = S.fromList (concatMap tv vs) + fieldType = cf_type field + fieldSet = S.fromList (tv fieldType) doStructDer _ _ _ i vs cs (CTypeclass di) | isTCId i = -- ignore bad deriving, it should be handled in the data case Right [] @@ -319,7 +329,8 @@ doSBits dpos ti vs fields = Cinstance (CQType ctx (cTApplys (cTCon idBits) [aty, [cTVarKind s KNum, cTVarKind a KNum, cTVarKind n KNum] : f n ss nn f _ _ _ = internalError "Deriving.doSBits.f: _ (_:_) []" - b:bs = reverse bvs + (b, bs) = unconsOrErr "Deriving.doSBits: null bvs" $ + reverse bvs in if null fields then [] else f b bs avs avs = take (n-1) (everyThird tmpTyVarIds) bvs = take n (everyThird (tail tmpTyVarIds)) @@ -455,9 +466,11 @@ doDBits dpos type_name type_vars original_tags tags = f a (s:ss) (n:nn) = CPred (CTypeclass idMax) [s, a, n] : f n ss nn f _ _ _ = internalError "Deriving.doDBits.f: _ (_:_) []" - b:bs = reverse field_bit_sizes + (b, bs) = unconsOrErr "Deriving.doDBits: null field_bit_sizes" $ + reverse field_bit_sizes in f b bs max_field_size_sofar_vars - num_rep_bits_var:max_field_size_sofar_vars = + (num_rep_bits_var, max_field_size_sofar_vars) = + unconsOrErr "Deriving.doDBits: tmpTyVarIds" $ make_num_vars num_tags (everyThird tmpTyVarIds) -- max_num_field_bits: # bits required to represent all fields w/o tags max_num_field_bits = last max_field_size_sofar_vars @@ -945,9 +958,11 @@ addAutoDeriv flags r i tvs clsId derivs -- incoherent matches are resolved *after* reducePred | Right True <- fst (runTI flags False r check) = derivs where check = do - let Just (TypeInfo _ kind _ sort) = + let (kind, sort) = -- trace ("check undef: " ++ show clsId) $ - findType r i + case findType r i of + Just (TypeInfo _ k _ s) -> (k, s) + _ -> internalError "Deriving.addAutoDeriv: findType" let t = cTApplys (TCon (TyCon i (Just kind) sort)) tvs cls <- findCls (CTypeclass clsId) -- Look for an instance where the first parameter is the specified type diff --git a/src/comp/GenWrap.hs b/src/comp/GenWrap.hs index 6ed270b66..a9d89a6f9 100644 --- a/src/comp/GenWrap.hs +++ b/src/comp/GenWrap.hs @@ -636,7 +636,9 @@ genWrapInfo genifcs (d@(CDef modName oqt@(CQType _ t) cls), cqt, _, pps) = ifcNameFromMod :: [PProp] -> Type -> GWMonad Id ifcNameFromMod localpps localt = flatTypeIdQual localpps tr where - (_, TAp _ tr) = getArrows localt + tr = case getArrows localt of + (_, TAp _ r) -> r + _ -> internalError "GenWrap.genWrapInfo ifcNameFromMod: tr" genWrapInfo _ (def,_,_,_) = internalError( "genWrapInfo: unexpected def: " ++ ppReadable def ) @@ -886,7 +888,8 @@ genIfcField trec ifcIdIn prefixes (FInf fieldIdQ argtypes rettype _) = return ((concat fields), (concat props)) _ -> -- leaf function do - let v:vs = map cTVarNum (take (length argtypes + 1) tmpTyVarIds) + let (v, vs) = unconsOrErr "GenWrap.genIfcField: v:vs" $ + map cTVarNum (take (length argtypes + 1) tmpTyVarIds) let bitsCtx a s = CPred (CTypeclass idBits) [a, s] let ctx = zipWith bitsCtx argtypes vs let ss = map (TAp tBit) vs @@ -985,7 +988,8 @@ genIfcFieldFN trec rootId prefixes (FInf fieldIdQ argtypes r _) = Nothing -> -- leaf function do symt <- getSymTab - let v:vs = map cTVarNum (take (length argtypes + 1) tmpTyVarIds) + let (v, vs) = unconsOrErr "GenWrap.genIfcFieldFN: v:vs" $ + map cTVarNum (take (length argtypes + 1) tmpTyVarIds) isTClock t = t == tClock isTReset t = t == tReset isTInout t = (leftCon t == Just idInout) @@ -1353,7 +1357,9 @@ mkNewModDef genIfcMap (def@(CDef i (CQType _ t) dcls), cqt, vtis, vps) = do -- XXX This could have been stored in the moduledef info -- XXX (note that the first half is the "ts" in "vtis") - let (_, TAp _ tr) = getArrows t + let tr = case getArrows t of + (_, TAp _ r) -> r + _ -> internalError "GenWrap.mkNewModDef: tr" tyId <- flatTypeId vps tr -- id of the Ifc_ let ty = tmod (cTCon tyId) -- type of new module @@ -1362,7 +1368,9 @@ mkNewModDef genIfcMap (def@(CDef i (CQType _ t) dcls), cqt, vtis, vps) = Just res -> res Nothing -> internalError ("mkNewModDef: can't find ifc: " ++ ppReadable tyId) - (Cstruct _ _ _ _ cfields _) = genifc_cdefn genifc + cfields = case genifc_cdefn genifc of + (Cstruct _ _ _ _ cs _) -> cs + _ -> internalError "GenWrap.mkNewModDef: cfields" -- XXX reverse the fields just to match the behvaior of the previous -- XXX compiler, which accumulated with fold rather than map ftps <- mapM collectIfcInfo (reverse cfields) @@ -1488,7 +1496,9 @@ mkDef iprags pps (CDef i (CQType _ qt) _) cqt = do st0 <- get return (\fmod wire_info sch pathinfo ips symt fields true_ifc_ids -> do let - (ts, TAp _ tr) = getArrows qt + (ts, tr) = case getArrows qt of + (ats, TAp _ r) -> (ats, r) + _ -> internalError "GenWrap.mkDef: ts, tr" st1 = st0 { symtable = symt } -- do not use ifc prags here (st2, ti_) <- runGWMonadGetNoFail (flatTypeId pps tr) st1 @@ -1753,7 +1763,9 @@ chkInterface t = do --traceM("getFInf: before: " ++ ppReadable(ft)) ft_ext <- expandSynSym ft --traceM("getFInf: after: " ++ show(ft_ext)) - let (_:as, r) = getArrows ft_ext + let (as, r) = case getArrows ft_ext of + (_:ats, rt) -> (ats, rt) + _ -> internalError "GenWrap.chkInterface: as, r" -- get any user-declared names for the arguments symt <- getSymTab let aIds = getMethodArgNames symt ti f @@ -2154,7 +2166,9 @@ chkUserPragmas pps ifc = do when (null pp_ids) $ return () -- find the fields of the flattened ifc - let (Cstruct _ _ _ _ fields _) = genifc_cdefn ifc + let fields = case genifc_cdefn ifc of + (Cstruct _ _ _ _ cs _) -> cs + _ -> internalError "GenWrap.chkUserPragmas: fields" -- identify which fields are methods let dropQ (CQType _ t) = t diff --git a/src/comp/GraphMap.hs b/src/comp/GraphMap.hs index bc94b3f95..86a35e54d 100644 --- a/src/comp/GraphMap.hs +++ b/src/comp/GraphMap.hs @@ -109,7 +109,7 @@ instance (PPrint v, PPrint w) => PPrint (GraphMap v w) where -- non-connected components ncc :: Ord v => GraphMap v w -> [[v]] -ncc g | null g = [[]] - | otherwise = ncvs:(ncc $ deleteVertices g ncvs) - where (v:vs) = vertices g - ncvs = v:[v' | v' <- vs, (v,v') `member` g] +ncc g = case (vertices g) of + [] -> [[]] + (v:vs) -> let ncvs = v:[v' | v' <- vs, (v,v') `member` g] + in ncvs:(ncc $ deleteVertices g ncvs) diff --git a/src/comp/IConv.hs b/src/comp/IConv.hs index e275fa740..2053a0deb 100644 --- a/src/comp/IConv.hs +++ b/src/comp/IConv.hs @@ -141,7 +141,9 @@ iConvD _ _ _ _ _ _ _ = [] -- only qualify non-instance names qualId' :: Id -> Id -> Id qualId' pi i = if tilde `elem` getIdString i then i else qualId pi i - where [tilde] = getFString fsTilde + where tilde = case getFString fsTilde of + [c] -> c + _ -> internalError "IConv.qualId': unexpected tilde string" iConvVS :: ErrorHandle -> Flags @@ -203,8 +205,12 @@ iConvPs' flags r env cond bs n ((v, _, CPConTs ti i ots [pat]) : ps) = iConvPs' flags r env (cond . isTest) bs n ((out, argType ty, pat) : ps) where ts = map (iConvT flags r) ots (conty, cti) = lookupConType flags ti i r - outty = underForAll conty (length ts) (\ (ITAp (ITAp arr a) r) -> ITAp (ITAp arr r) a) - isty = underForAll conty (length ts) (\ (ITAp (ITAp arr a) r) -> ITAp (ITAp arr r) itBit1) + mkOutTy (ITAp (ITAp arr a) r) = ITAp (ITAp arr r) a + mkOutTy _ = internalError "IConv.iConvPs' mkOutTy" + mkIsTy (ITAp (ITAp arr a) r) = ITAp (ITAp arr r) itBit1 + mkIsTy _ = internalError "IConv.iConvPs' mkIsTy" + outty = underForAll conty (length ts) mkOutTy + isty = underForAll conty (length ts) mkIsTy out = IAps (ICon i (ICOut outty cti)) ts [v] is = IAps (ICon i (ICIs isty cti)) ts [v] isTest = if numCon cti == 1 then id else (is `ieAnd`) @@ -218,7 +224,10 @@ iConvPs' flags r env cond bs n ((v, t, CPstruct _ _ fs) : ps) = iConvPs' flags r env cond bs (n+length fs) (foldr addP ps fs) where (ti, ts) = splitITApCon t addP (f, p) ps = - let sel@(ICon _ (ICSel selty _ _)) = iConvField flags r ti f + let sel = iConvField flags r ti f + selty = case sel of + (ICon _ (ICSel t _ _)) -> t + _ -> internalError "IConv.iConvPs' CPstruct: selty" ty = iInst selty ts in --trace ("iConvPs' " ++ ppReadable (sel, selty, ts, ty)) $ (IAps sel ts [v], resType ty, p) : ps @@ -357,9 +366,11 @@ iConvLet errh flags r env pvs ds = answer where ite env pvs = iConvVS errh flags r env pvs i vs qt cs f _ = internalError "iConvLet.ites.f" - env' = foldr (\ (CLValueSign (CDefT i _ _ _) _) -> addVar i (IVar i)) env ds + d_ids = [ i | (CLValueSign (CDefT i _ _ _) _) <- ds ] + env' = let addFn i e = addVar i (IVar i) e + in foldr addFn env d_ids is :: S.Set Id - is = S.fromList (map ( \ d@(CLValueSign (CDefT i _ _ _) _) -> i) ds) + is = S.fromList d_ids graph :: SCC.Graph Id -- [(Id,[Id])] graph = [(i, local_is) | d@(CLValueSign (CDefT i _ _ _) _) <- ds, @@ -463,10 +474,8 @@ iConvE errh flags r env pvs eee@(CStructT ct fs@((f,_):_)) = st = argType (iInst fty tvs) -- Get rid of dictionary argument to primConcat & co iConvE errh flags r env pvs (CApply (CTApply (CVar i) ts) (_: es)) - | mf /= Nothing = + | (Just f) <- lookup i dropDicts = IAps f (map (iConvT flags r) ts) (map (iConvE errh flags r env pvs) es) - where mf = lookup i dropDicts - Just f = mf -- XXX should get rid of primSplitFst & primSplitSnd iConvE errh flags r env pvs (CApply (CTApply (CVar sfst) [t1,t2,t3]) [_, e]) | sfst == idPrimSplitFst = @@ -550,7 +559,9 @@ iConvE errh flags r env pvs e@(CmoduleVerilogT ty name ui clks rst args meths sc getMethodName (Inout { vf_name = i }) = i tss = map (tail . itSplit . getMethodType flags r ti ts . getMethodName) meths ty' = iConvT flags r ty - ITAp _ ty'' = dropA es' ty' + ty'' = case dropA es' ty' of + ITAp _ t -> t + _ -> internalError "IConv.iConvE CmoduleVerilogT: dropA result" where dropA [] t = t dropA (_:es) (ITAp _ t) = dropA es t dropA _ _ = internalError "IConv.iConvE.dropA" @@ -574,7 +585,10 @@ iConvE errh flags r env pvs e = internalError ("IConv.iConvE:" ++ ppReadable e) getMethodType :: Flags -> SymTab -> Id -> [IType] -> Id -> IType getMethodType flags r ti ts m = iInst selty ts - where ICon _ (ICSel selty _ _) = iConvField flags r ti m + where sel = iConvField flags r ti m + selty = case sel of + (ICon _ (ICSel t _ _)) -> t + _ -> internalError "IConv.getMethodType: selty" iConvR :: ErrorHandle -> Flags -> SymTab -> Env a -> IPVars a -> CRule -> IExpr a diff --git a/src/comp/IExpand.hs b/src/comp/IExpand.hs index 705711ad0..100a61e6f 100644 --- a/src/comp/IExpand.hs +++ b/src/comp/IExpand.hs @@ -1074,7 +1074,9 @@ iExpandMethodLam modId n args implicitCond clkRst (i, bi, eb) li ty p = do let inps :: [VPort] inps = vf_inputs wf1 let wf1' :: VFieldInfo - wf1' = wf1 { vf_inputs = ((id_to_vPort i'):inps) } + wf1' = case wf1 of + (Method {}) -> wf1 { vf_inputs = ((id_to_vPort i'):inps) } + _ -> internalError "iExpandMethodLam: unexpected wf1" return ((i', ty) : its, (d, ws1, wf1'), (wd, ws2, wf2)) iExpandMethod' :: HPred -> HClock -> (Id, BetterInfo.BetterInfo, HExpr) -> @@ -3105,7 +3107,9 @@ conAp' c (ICOut { iConType = outty, conTagInfo = cti }) o as = case dropT as of E e : as' -> do let tys = takeT as - ITAp _ ty = itInst outty tys + ty = case itInst outty tys of + (ITAp _ t) -> t + _ -> internalError "IExpand.conAp' ICOut: ty" resType = dropArrows (length as') ty {- -- XXX do we need to heap the args, to avoid duplication? let toHeapArg (E e) = toHeapInferName "out-arg" e >>= return . E @@ -3118,7 +3122,9 @@ conAp' c (ICSel { iConType = selty, selNo = n }) sel as = case dropT as of E e : as' -> do let tys = takeT as - ITAp _ ty = itInst selty tys + ty = case itInst selty tys of + (ITAp _ t) -> t + _ -> internalError "IExpand.conAp' ICSel: ty" resType = dropArrows (length as') ty {- -- XXX do we need to heap the args, to avoid duplication? let toHeapArg (E e) = toHeapInferName "sel-arg" e >>= return . E @@ -4290,7 +4296,9 @@ improveIf :: HExpr -> IType -> HExpr -> HExpr -> HExpr -> G (HExpr, Bool) improveIf f t cnd (ICon i1 (ICLazyArray { iConType = ct1, iArray = arr1 })) (ICon i2 (ICLazyArray { iConType = ct2, iArray = arr2 })) | Array.bounds arr1 == Array.bounds arr2 = do when doTraceIf $ traceM("improveIf array triggered" ++ show i1 ++ show i2) - let ITAp _ elemType = t -- type must be (PrimArray t) + let elemType = case t of + ITAp _ te -> te -- type must be (PrimArray t) + _ -> internalError "IExpand.improveIf arrsz1 == arrsz2: elemType" refs1 = Array.elems arr1 refs2 = Array.elems arr2 refs' <- zipWithM (\ref1 ref2 -> if (ac_ptr ref1) == (ac_ptr ref2) then diff --git a/src/comp/ISimplify.hs b/src/comp/ISimplify.hs index eb474d478..98537a00b 100644 --- a/src/comp/ISimplify.hs +++ b/src/comp/ISimplify.hs @@ -1,6 +1,8 @@ module ISimplify(iSimplify) where + import Data.List((\\)) import qualified Data.Map as M +import Util(fromJustOrErr) import PPrint import IntLit import ErrorUtil @@ -52,11 +54,11 @@ iSimpAp n (ILam i _ e) [] (a:as) in iSimpAp n e' [] as iSimpAp _ (ICon _ (ICPrim _ prim)) ts es | m /= Nothing = r where m = doPrim prim ts es - Just r = m + r = fromJustOrErr "iSimpAp ICPrim Nothing" m iSimpAp n f@(ICon _ (ICSel { selNo = k })) ts es@(def : as) | n && m /= Nothing = {-trace (ppReadable (IAps f ts es, e'))-} e' where m = getTuple def - Just ms = m + ms = fromJustOrErr "iSimpAp ICSel Nothing" m e' = iSimpAp n (iSimp n (ms !! fromInteger k)) [] as iSimpAp n e [] [] = e -- iSimp has already been called iSimpAp n f ts es = IAps f ts es diff --git a/src/comp/ISyntaxUtil.hs b/src/comp/ISyntaxUtil.hs index 15f13c89c..d67fdde89 100644 --- a/src/comp/ISyntaxUtil.hs +++ b/src/comp/ISyntaxUtil.hs @@ -82,14 +82,14 @@ icPair i = ICon i (ICTuple ct [idPrimFst, idPrimSnd]) (ITForAll i2 IKStar ((ITVar i1) `itFun` (ITVar i2) `itFun` pair_t)) pair_t = itPair (ITVar i1) (ITVar i2) - i1:i2:_ = tmpVarIds + (i1, i2) = take2tmpVarIds itPosition, itPrimGetPosition :: IType itPosition = ITCon idPosition IKStar tiPosition -- type for position extraction primitives -- PrimGetEvalPosition is only the first example of this itPrimGetPosition = ITForAll i IKStar (ITVar i `itFun` itPosition) - where i = head tmpVarIds + where i = take1tmpVarIds itName :: IType itName = ITCon idName IKStar tiName @@ -309,7 +309,7 @@ iMkInvalid t = IAps icPrimChr [mkNumConT 1, itMaybe t] [iMkLitSize 1 0] iMkValid :: IType -> IExpr a -> IExpr a iMkValid t e = - let a:_ = tmpVarIds + let a = take1tmpVarIds ic_ty = ITForAll a IKStar $ (ITVar a) `itFun` (itMaybe (ITVar a)) cti = ConTagInfo { conNo = 1, numCon = 2, conTag = 1, tagSize = 1 } ic = ICon idValid (ICCon { iConType = ic_ty, conTagInfo = cti }) @@ -320,7 +320,7 @@ iMkNil t = IAps icPrimChr [mkNumConT 1, itList t] [iMkLitSize 1 0] iMkCons :: IType -> IExpr a -> IExpr a -> IExpr a iMkCons t e_hd e_tl = - let a:_ = tmpVarIds + let a = take1tmpVarIds ic_ty = ITForAll a IKStar $ (ITVar a) `itFun` (itList (ITVar a)) `itFun` (itList (ITVar a)) cti = ConTagInfo { conNo = 1, numCon = 2, conTag = 1, tagSize = 1 } @@ -493,7 +493,7 @@ icNoActions = ICon idPrimNoActions (ICPrim itAction PrimNoActions) icIf :: IExpr a icIf = ICon idPrimIf (ICPrim (ITForAll i IKStar (itBit1 `itFun` ty `itFun` ty `itFun` ty)) PrimIf) - where i = head tmpVarIds + where i = take1tmpVarIds ty = ITVar i icPrimArrayDynSelect :: IExpr a @@ -504,14 +504,14 @@ icPrimArrayDynSelect = ICon idPrimArrayDynSelect (ICPrim t PrimArrayDynSelect) t = ITForAll a IKStar $ ITForAll n IKNum $ arr_ty `itFun` idx_ty `itFun` elem_ty - a:n:_ = tmpVarIds + (a, n) = take2tmpVarIds icPrimBuildArray :: (Num a, Enum a) => a -> IExpr b icPrimBuildArray sz = ICon idPrimBuildArray (ICPrim t PrimBuildArray) where elem_ty = ITVar i arr_ty = ITAp itPrimArray elem_ty t = ITForAll i IKStar $ foldr (\ e f -> elem_ty `itFun` f) arr_ty [1..sz] - i = head tmpVarIds + i = take1tmpVarIds -- n is the number of explicit arms, not counting the default arm icPrimCase :: (Num a, Enum a) => a -> IExpr b @@ -523,84 +523,84 @@ icPrimCase sz = ICon idPrimCase (ICPrim t PrimCase) idx_ty `itFun` elem_ty `itFun` (foldr (\ e f -> idx_ty `itFun` elem_ty `itFun` f) elem_ty [1..sz]) - n:a:_ = tmpVarIds + (n, a) = take2tmpVarIds icPrimOrd :: IExpr a icPrimOrd = ICon idPrimOrd (ICPrim t PrimOrd) where t = ITForAll a IKStar (ITForAll n IKNum (ITVar a `itFun` aitBit (ITVar n))) - a:n:_ = tmpVarIds + (a, n) = take2tmpVarIds icPrimChr :: IExpr a icPrimChr = ICon idPrimChr (ICPrim t PrimChr) where t = ITForAll n IKNum (ITForAll a IKStar (aitBit (ITVar n) `itFun` ITVar a)) - n:a:_ = tmpVarIds + (n, a) = take2tmpVarIds icSelect :: Position -> IExpr a icSelect pos = ICon (idPrimSelectAt pos) (ICPrim t PrimSelect) where t = ITForAll k IKNum (ITForAll m IKNum (ITForAll n IKNum rt)) rt = aitBit (ITVar n) `itFun` aitBit (ITVar k) - k:m:n:_ = tmpVarIds + (k, m, n) = take3tmpVarIds icPrimConcat :: IExpr a icPrimConcat = ICon idPrimConcat (ICPrim t PrimConcat) where t = ITForAll k IKNum (ITForAll m IKNum (ITForAll n IKNum rt)) rt = aitBit (ITVar k) `itFun` aitBit (ITVar m) `itFun` aitBit (ITVar n) - k:m:n:_ = tmpVarIds + (k, m, n) = take3tmpVarIds icPrimMul :: IExpr a icPrimMul = ICon idPrimMul (ICPrim t PrimMul) where t = ITForAll k IKNum (ITForAll m IKNum (ITForAll n IKNum rt)) rt = aitBit (ITVar k) `itFun` aitBit (ITVar m) `itFun` aitBit (ITVar n) - k:m:n:_ = tmpVarIds + (k, m, n) = take3tmpVarIds icPrimQuot :: IExpr a icPrimQuot = ICon idPrimQuot (ICPrim t PrimQuot) where t = ITForAll k IKNum (ITForAll n IKNum rt) rt = aitBit (ITVar k) `itFun` aitBit (ITVar n) `itFun` aitBit (ITVar k) - k:n:_ = tmpVarIds + (k, n) = take2tmpVarIds icPrimRem :: IExpr a icPrimRem = ICon idPrimRem (ICPrim t PrimRem) where t = ITForAll k IKNum (ITForAll n IKNum rt) rt = aitBit (ITVar k) `itFun` aitBit (ITVar n) `itFun` aitBit (ITVar n) - k:n:_ = tmpVarIds + (k, n) = take2tmpVarIds icPrimZeroExt :: IExpr a icPrimZeroExt = ICon idPrimZeroExt (ICPrim t PrimZeroExt) where t = ITForAll m IKNum (ITForAll k IKNum (ITForAll n IKNum rt)) rt = aitBit (ITVar k) `itFun` aitBit (ITVar n) - k:m:n:_ = tmpVarIds + (k, m, n) = take3tmpVarIds icPrimSignExt :: IExpr a icPrimSignExt = ICon idPrimSignExt (ICPrim t PrimSignExt) where t = ITForAll m IKNum (ITForAll k IKNum (ITForAll n IKNum rt)) rt = aitBit (ITVar k) `itFun` aitBit (ITVar n) - k:m:n:_ = tmpVarIds + (k, m, n) = take3tmpVarIds icPrimTrunc :: IExpr a icPrimTrunc = ICon idPrimTrunc (ICPrim t PrimTrunc) where t = ITForAll k IKNum (ITForAll m IKNum (ITForAll n IKNum rt)) rt = aitBit (ITVar n) `itFun` aitBit (ITVar m) - k:m:n:_ = tmpVarIds + (k, m, n) = take3tmpVarIds icPrimRel :: Id -> PrimOp -> IExpr a icPrimRel id p = ICon id (ICPrim (ITForAll i IKNum (ty `itFun` ty `itFun` itBit1)) p) - where i = head tmpVarIds + where i = take1tmpVarIds ty = itBit `ITAp` ITVar i icPrimWhen :: IExpr a icPrimWhen = ICon idPrimWhen (ICPrim t PrimWhen) where t = ITForAll i IKStar (itBit1 `itFun` ITVar i `itFun` ITVar i) - i = head tmpVarIds + i = take1tmpVarIds icPrimWhenPred :: IExpr a icPrimWhenPred = ICon idPrimWhen (ICPrim t PrimWhenPred) where t = ITForAll i IKStar (itPred `itFun` ITVar i `itFun` ITVar i) - i = head tmpVarIds + i = take1tmpVarIds itUninitialized :: IType itUninitialized = ITForAll i IKStar (itPosition `itFun` itString `itFun` ITVar i) - where i = head tmpVarIds + where i = take1tmpVarIds icPrimRawUninitialized, icPrimUninitialized :: IExpr a icPrimRawUninitialized = ICon idPrimRawUninitialized (ICPrim itUninitialized PrimRawUninitialized) @@ -609,19 +609,19 @@ icPrimUninitialized = ICon idPrimUninitialized (ICPrim itUninitialized PrimUnini icPrimSetSelPosition :: IExpr a icPrimSetSelPosition = ICon idPrimSetSelPosition (ICPrim t PrimSetSelPosition) where t = ITForAll i IKStar (itPosition `itFun` ITVar i `itFun` ITVar i) - i = head tmpVarIds + i = take1tmpVarIds icPrimSL :: IExpr a icPrimSL = ICon idPrimSL (ICPrim t PrimSL) where t = ITForAll i IKNum (ty `itFun` itNat `itFun` ty) ty = itBit `ITAp` ITVar i - i = head tmpVarIds + i = take1tmpVarIds icPrimSRL :: IExpr a icPrimSRL = ICon idPrimSRL (ICPrim t PrimSRL) where t = ITForAll i IKNum (ty `itFun` itNat `itFun` ty) ty = itBit `ITAp` ITVar i - i = head tmpVarIds + i = take1tmpVarIds icPrimEQ, icPrimULE, icPrimULT, icPrimSLE, icPrimSLT :: IExpr a icPrimEQ = icPrimRel idPrimEQ PrimEQ @@ -634,7 +634,7 @@ icPrimSLT = icPrimRel idPrimSLT PrimSLT icPrimBinVecOp :: Id -> PrimOp -> IExpr a icPrimBinVecOp id p = ICon id (ICPrim t p) where t = ITForAll i IKNum (ty `itFun` ty `itFun` ty) - i = head tmpVarIds + i = take1tmpVarIds ty = itBit `ITAp` ITVar i icPrimAdd, icPrimSub :: IExpr a @@ -644,14 +644,14 @@ icPrimSub = icPrimBinVecOp idPrimSub PrimSub icPrimInv :: IExpr a icPrimInv = ICon idPrimSL (ICPrim t PrimInv) where t = ITForAll i IKNum (ty `itFun` ty) - i = head tmpVarIds + i = take1tmpVarIds ty = itBit `ITAp` ITVar i icPrimIntegerToBit :: IExpr a icPrimIntegerToBit = ICon (idFromInteger noPosition) (ICPrim t PrimIntegerToBit) where t = ITForAll i IKNum (itInteger `itFun` (aitBit ty)) ty = ITVar i - i = head tmpVarIds + i = take1tmpVarIds icClock :: Id -> IClock a -> IExpr a icClock i c = ICon i (ICClock {iConType = itClock, iClock = c}) diff --git a/src/comp/ITransform.hs b/src/comp/ITransform.hs index 4a2c9bf57..95e2a5c7e 100644 --- a/src/comp/ITransform.hs +++ b/src/comp/ITransform.hs @@ -20,11 +20,11 @@ import Prelude hiding ((<>)) import Data.Traversable (forM) import Control.Monad.State hiding (forM) import Data.List((\\)) -import Data.Maybe(isJust) import qualified Data.Map as M import IntegerUtil(mask, integerAnd) -import Util(log2, itos, appFstM, snd3, makePairs, flattenPairs) +import Util(log2, itos, appFstM, snd3, makePairs, flattenPairs, + fromJustOrErr) import PPrint import IntLit import Position(noPosition, getPosition) @@ -334,13 +334,9 @@ iTrAp ctx p@(ICon _ (ICPrim _ PrimIf)) [t] [cnd, thn, els] -- XXX Can this ever be harmful? It removes a constant... -- if (x == k) k e --> if (x == k) x e - (cnd', _, _) | - (case cnd' of - (IAps (ICon _ (ICPrim _ PrimEQ)) _ [x, k@(ICon _ _)]) -> k == thn && thn /= x - _ -> False - ) - -> iTrAp2 ctx p [t] [cnd, x, els] - where (IAps _ _ [x, _]) = cnd' + (IAps (ICon _ (ICPrim _ PrimEQ)) _ [x, k@(ICon _ _)], _, _) + | k == thn && thn /= x + -> iTrAp2 ctx p [t] [cnd, x, els] -- We used to perform this tagging -- (only for bit-type, not Action, and not in the evaluator) @@ -599,15 +595,15 @@ iTrAp ctx (ICon _ (ICPrim _ PrimMul)) [sk@(ITNum k_size),se,sz] [c,e] | isOne c -- e * 2^k --> e << k iTrAp ctx (ICon _ (ICPrim _ PrimMul)) [se,sk@(ITNum k_size),sz] [e, ICon _ (ICInt { iVal = IntLit { ilValue = n } })] | m /= Nothing = iTrAp2 ctx icPrimSL [sz, ITNum 32] [e', iMkLit itNat k] - where e' = iTrApExp ctx icPrimConcat [sk, se, sz] [iMkLitSize k_size 0, e] - m = iLog2 n - Just k = m + where e' = iTrApExp ctx icPrimConcat [sk, se, sz] [iMkLitSize k_size 0, e] + m = iLog2 n + k = fromJustOrErr "iTraAp iLog2" m -- 2^k * e --> e << k iTrAp ctx (ICon _ (ICPrim _ PrimMul)) [sk@(ITNum k_size),se,sz] [ICon _ (ICInt { iVal = IntLit { ilValue = n } }), e] | m /= Nothing = iTrAp2 ctx icPrimSL [sz, ITNum 32] [e', iMkLit itNat k] - where e' = iTrApExp ctx icPrimConcat [sk, se, sz] [iMkLitSize k_size 0, e] - m = iLog2 n - Just k = m + where e' = iTrApExp ctx icPrimConcat [sk, se, sz] [iMkLitSize k_size 0, e] + m = iLog2 n + k = fromJustOrErr "iTraAp iLog2" m -- 0 | e --> e -- 1 | e --> 1 @@ -710,8 +706,8 @@ iTrAp ctx (ICon _ (ICPrim _ PrimQuot)) _ [e, c] | isOne c = (e, True) -- e / 2^k --> e >> k iTrAp ctx (ICon _ (ICPrim _ PrimQuot)) [se,_] [e, ICon _ (ICInt { iVal = IntLit { ilValue = n } })] | m /= Nothing = iTrAp2 ctx icPrimSRL [se] [e, iMkLit itNat k] - where m = iLog2 n - Just k = m + where m = iLog2 n + k = fromJustOrErr "iTraAp iLog2" m -- e % 1 --> 0 iTrAp ctx (ICon _ (ICPrim _ PrimRem)) [_,sk] [_,c] | isOne c = (mkZero sk, True) @@ -721,10 +717,10 @@ iTrAp ctx (ICon remid (ICPrim _ PrimRem)) [se,sk@(ITNum k_size)] [e, ICon _ (ICI | m /= Nothing = if (pad == 0) then (e', True) else iTrAp2 ctx icPrimConcat [ITNum pad, ITNum k, sk] [iMkLitSize pad 0, e'] - where e' = iTrApExp ctx (icSelect (getIdPosition remid)) [(ITNum k), ITNum 0, se] [e] - m = iLog2 n - Just k = m - pad = k_size - k + where e' = iTrApExp ctx (icSelect (getIdPosition remid)) [(ITNum k), ITNum 0, se] [e] + m = iLog2 n + k = fromJustOrErr "iTraAp iLog2" m + pad = k_size - k -- e < 0 --> False -- e <= 0 --> e == 0 @@ -838,12 +834,11 @@ iTrAp ctx p@(ICon _ (ICPrim _ prim)) [t] [e1,e2] _ -> internalError("iTrAp: associativity") -- extract n k e h l --> zeroExt (h-l+1) (k-(h-l+1)) k (select (h-l+1) l n e) -iTrAp ctx fun@(ICon iext (ICPrim _ PrimExtract)) ts@[tn@(ITNum n), _, ITNum k] es@[e, eh, el] | isIConInt eh && isIConInt el = --- iTrAp ctx icPrimZeroExt [mkNumConT k_sz, mkNumConT sz, mkNumConT k] [exp] - iTrAp2 ctx icPrimConcat [mkNumConT k_sz, mkNumConT sz, mkNumConT k] [iMkLitSize k_sz 0, exp] - where exp = iTrApExp ctx (icSelect (getIdPosition iext)) [mkNumConT sz, mkNumConT l, tn] [e] - ICon _ (ICInt { iVal = IntLit { ilValue = h } }) = eh - ICon _ (ICInt { iVal = IntLit { ilValue = l } }) = el +iTrAp ctx fun@(ICon iext (ICPrim _ PrimExtract)) ts@[tn@(ITNum n), _, ITNum k] es@[e, eh, el] + | (ICon _ (ICInt { iVal = IntLit { ilValue = h } })) <- eh + , (ICon _ (ICInt { iVal = IntLit { ilValue = l } })) <- el + = let + exp = iTrApExp ctx (icSelect (getIdPosition iext)) [mkNumConT sz, mkNumConT l, tn] [e] sz = mask 32 (h-l+1) -- mask it to allow h == l-1 k_sz = if k < sz then internalError("extraction size (" ++ show sz ++ ") " ++ @@ -851,6 +846,9 @@ iTrAp ctx fun@(ICon iext (ICPrim _ PrimExtract)) ts@[tn@(ITNum n), _, ITNum k] e show k ++ "):\n" ++ ppReadable (IAps fun ts es)) else k - sz + in +-- iTrAp ctx icPrimZeroExt [mkNumConT k_sz, mkNumConT sz, mkNumConT k] [exp] + iTrAp2 ctx icPrimConcat [mkNumConT k_sz, mkNumConT sz, mkNumConT k] [iMkLitSize k_sz 0, exp] -- select n k m e --> error, n+k > m iTrAp ctx fun@(ICon sel (ICPrim _ PrimSelect)) ts@[ITNum n, ITNum k, ITNum m] as | n+k > m = @@ -903,10 +901,11 @@ iTrAp ctx rel_c@(ICon _ (ICPrim _ p)) t1@[ITNum i1] [e', c] | in (ap e', True) -- c RELOP x --> x (flip RELOP) c -iTrAp ctx e0@(ICon _ (ICPrim _ p)) [t] [e1, e2] | isJust mfp && isIConInt e1 && not (isIConInt e2) = fp [t] [e2, e1] - where mfp = flipOp p - Just fp = mfp - flipOp PrimEQ = Just $ \ ts es -> iTrAp2 ctx icPrimEQ ts es +iTrAp ctx e0@(ICon _ (ICPrim _ p)) [t] [e1, e2] + | (Just fp) <- flipOp p + , isIConInt e1 && not (isIConInt e2) + = fp [t] [e2, e1] + where flipOp PrimEQ = Just $ \ ts es -> iTrAp2 ctx icPrimEQ ts es flipOp PrimULT = Just $ \ ts es -> iTrAp2 ctx iNot [] [iTrApExp ctx icPrimULE ts es] flipOp PrimULE = Just $ \ ts es -> iTrAp2 ctx iNot [] [iTrApExp ctx icPrimULT ts es] flipOp PrimSLT = Just $ \ ts es -> iTrAp2 ctx iNot [] [iTrApExp ctx icPrimSLE ts es] @@ -1588,15 +1587,15 @@ optE m e0@(IAps p@(ICon _ (ICPrim _ PrimBAnd)) ts [e1, e2]) = let (m1, e1') = optE m e1 (m2, e2') = optE m1 e2 in (m2, IAps p ts [e1', e2']) -optE m e@(IAps p@(ICon _ (ICPrim _ cmp)) _ [v, ICon _ (ICInt { iConType = t, iVal = IntLit { ilValue = i } })]) | isCmp cmp && mn /= Nothing = - doCmp m e cmp v n i True - where mn = getBit t - Just n = mn +optE m e@(IAps p@(ICon _ (ICPrim _ cmp)) _ [v, ICon _ (ICInt { iConType = t, iVal = IntLit { ilValue = i } })]) + | isCmp cmp + , (Just n) <- getBit t + = doCmp m e cmp v n i True optE m e@(IAps (ICon _ (ICPrim _ PrimBNot)) _ - [IAps p@(ICon _ (ICPrim _ cmp)) ts [v, ICon _ (ICInt { iConType = t, iVal = IntLit { ilValue = i } })]]) | isCmp cmp && mn /= Nothing = - doCmp m e cmp v n i False - where mn = getBit t - Just n = mn + [IAps p@(ICon _ (ICPrim _ cmp)) ts [v, ICon _ (ICInt { iConType = t, iVal = IntLit { ilValue = i } })]]) + | isCmp cmp + , (Just n) <- getBit t + = doCmp m e cmp v n i False optE m e = case vsGetSingleton e m of Nothing -> (m, e) diff --git a/src/comp/Id.hs b/src/comp/Id.hs index 11b293c5b..f7dec5127 100644 --- a/src/comp/Id.hs +++ b/src/comp/Id.hs @@ -585,11 +585,10 @@ setIdDisplayName :: Id -> FString -> Id setIdDisplayName idx name = addIdProp idx (IdPDisplayName name) addIdDisplayName :: Id -> Id -addIdDisplayName i | isNothing name' = i - where name' = getIdDisplayName i -addIdDisplayName i = i' - where (Just name') = getIdDisplayName i - i' = setIdBase i name' +addIdDisplayName i = + case (getIdDisplayName i) of + Nothing -> i + Just name -> setIdBase i name getFromReady :: Id -> String getFromReady idx = diff --git a/src/comp/MakeSymTab.hs b/src/comp/MakeSymTab.hs index 2546a08de..793604298 100644 --- a/src/comp/MakeSymTab.hs +++ b/src/comp/MakeSymTab.hs @@ -131,7 +131,7 @@ mkSymTab errh (CPackage mi _ imps _ ds _) = Left sccs -> sccs errMultipleDef (i:i':_) = - let [pos1, pos2] = sort [getIdPosition i, getIdPosition i'] + let (pos1, pos2) = sortPair (getIdPosition i, getIdPosition i') in (pos2, EMultipleDecl (pfpString i) pos1) errMultipleDef is = internalError ("MakeSymTab.mkSymTab.errMultipleDef: " ++ show is) @@ -395,7 +395,7 @@ cConvInst errh r (CPackage mi exps imps fixs ds includes) = convInst :: ErrorHandle -> Id -> SymTab -> CDefn -> CDefn convInst errh mi r di@(Cinstance qt@(CQType _ t) ds) = - let Just c = leftCon t + let c = fromJustOrErr "convInst: leftCon" (leftCon t) cls = mustFindClass r (CTypeclass c) instanceArgs = tyConArgs t clsMethType i = case schemes of @@ -450,7 +450,7 @@ convInst errh mi r di@(Cinstance qt@(CQType _ t) ds) = let s = mkSubst (zip vs ats) in apSub s (predToType p) bnd (pos, t) = - let Just tc = leftCon t + let tc = fromJustOrErr "convInst bnd: leftCon" (leftCon t) ts = tyConArgs t cqt = CQType [CPred (CTypeclass tc) ts] noType in (setIdPosition pos (unQualId tc), diff --git a/src/comp/PPrint.hs b/src/comp/PPrint.hs index 13ab3fc92..04543f5cf 100644 --- a/src/comp/PPrint.hs +++ b/src/comp/PPrint.hs @@ -112,15 +112,8 @@ instance (PPrint a, PPrint b, PPrint c, PPrint d, PPrint e, PPrint f, PPrint g) pPrint d _ (x, y, z, w, v, u, t) = text "(" <> sep [pPrint d 0 x <> text ",", pPrint d 0 y <> text ",", pPrint d 0 z <> text ",", pPrint d 0 w <> text ",", pPrint d 0 v <> text ",", pPrint d 0 u <> text ",", pPrint d 0 t] <> text ")" instance (PPrint a) => PPrint [a] where - pPrint d _ [] = text "[]" - pPrint d _ xs = - case reverse (map (pPrint d 0) xs) of - (y:ys) -> - let ys' = map (<> text ",") ys - xs' = reverse (y:ys') --- in text "[" <> csep xs' <> text "]" - in text "[" <> sep xs' <> text "]" - [] -> trace "This cannot happen" (text "[]") + pPrint d _ xs = let xs' = map (pPrint d 0) xs + in text "[" <> commaSep xs' <> text "]" instance (PPrint a, PPrint b) => PPrint (Either a b) where pPrint d p (Left x) = pparen (p>9) (text"(Left" <+> pPrint d 10 x <> text")") diff --git a/src/comp/Parser/BSV/CVParser.lhs b/src/comp/Parser/BSV/CVParser.lhs index e4ce8e17c..2c0bf13dc 100644 --- a/src/comp/Parser/BSV/CVParser.lhs +++ b/src/comp/Parser/BSV/CVParser.lhs @@ -901,7 +901,7 @@ if prefix is provided, sub-union and sub-struct constructors start with it > pTypedefStructField = > do mkSubUnion <- pTypedefTaggedUnionType False False > let mkField prefix params derivs = -> let ((name, fieldConstr, [_]), defns) = +> let ((name, fieldConstr, _), defns) = > mkSubUnion prefix params derivs > in (CField { cf_name = name, > cf_pragmas = Nothing, @@ -1002,7 +1002,7 @@ if prefix is provided, sub-union and sub-struct constructors start with it > return mkField > <|> do mkSubUnion <- pTypedefTaggedUnionType False True > let mkField prefix enc params derivs = -> let ((name, typeConstr, fieldTypes@[_]), defns) = +> let ((name, typeConstr, fieldTypes), defns) = > mkSubUnion prefix params derivs > original_summands = > COriginalSummand { cos_names = [name], @@ -2389,8 +2389,10 @@ must be bound (no mix and match of eq, decl only, bind with the same attrib). > pSemi > innards <- ( do prs <- try $ many1 (do as <- pAttributes > ir <- pImperativeRule as flags -> let [ISRule _ _ ps r] = ir -> return (ps,r) +> return $ +> case ir of +> [ISRule _ _ ps r] -> (ps, r) +> _ -> internalError "pImperativeRule innards" > ) > return (RRules prs) > <|> @@ -4746,7 +4748,7 @@ parameters to the parsers that might take them. > endpackage = maybe (return ()) > (pEndClause SV_KW_endpackage . Just) pkgId > when (not (null selfImports)) -- prohibit importing self -> (let (badImp : _) = selfImports +> (let badImp = head selfImports > badImpPos = getPosition badImp > emsg = ECircularImports [pvpString badImp] > in failWithErr (badImpPos, emsg)) @@ -5436,8 +5438,9 @@ Convert argument strings of attributes to CSchedulePragmas etc. > return els > result <- pAttributeWithParser pInside p s > return (if doingPreempts -> then (let [(is1,_,is2)] = result -> in SPPreempt is1 is2) +> then case result of +> [(is1,_,is2)] -> SPPreempt is1 is2 +> _ -> internalError "psScheduling: unexpected preempts result" > else SPSchedule (mkMethodConflictInfo result)) > psPerfSpec :: Position -> String -> SV_Parser PProp diff --git a/src/comp/Parser/BSV/CVParserAssertion.lhs b/src/comp/Parser/BSV/CVParserAssertion.lhs index b3d484af6..1b657d529 100644 --- a/src/comp/Parser/BSV/CVParserAssertion.lhs +++ b/src/comp/Parser/BSV/CVParserAssertion.lhs @@ -33,7 +33,7 @@ Look at transAssertStmt for a template. > import SEMonad > import PreIds > import PreStrings -> import Util(itos) +> import Util(itos, unconsOrErr) These functions unroll the sequences and properties and inline all parameters and sequences @@ -333,13 +333,17 @@ for recursive properties may be allowed. > if isSEQ > then do > mISSeq <- findSeqM nm -> let (Just (ISSequence _ (_,_,_,_,seq))) = mISSeq +> let seq = case mISSeq of +> (Just (ISSequence _ (_,_,_,_,s))) -> s +> _ -> internalError "CVParserAssertion.checkRecursionExpr: ISSeq" > checkRecursionSP (nm:calls) seq > return () > else if (isPROP) > then do > mISProp <- findPropM nm -> let (Just (ISProperty _ (_,_,_,_,seq))) = mISProp +> let seq = case mISProp of +> (Just (ISProperty _ (_,_,_,_,s))) -> s +> _ -> internalError "CVParserAssertion.checkRecursionExpr: ISProp" > checkRecursionSP (nm:calls) seq > return () > else return () @@ -1678,7 +1682,8 @@ Add a sequence to the environment > addSequence :: Id -> ImperativeStatement -> ISConvMonad () > addSequence nm body@(ISSequence pos _) = do > state <- get -> let seqs@(s:ss) = issSequences state +> let seqs = issSequences state +> (s, ss) = unconsOrErr "CVParserAssertion.addSequence: missing frame" seqs > case findSeq nm seqs of > Nothing -> put $ state {issSequences = (M.insert nm body s):ss} > Just (ISSequence prevPos decl) -> @@ -1710,7 +1715,8 @@ Add a property to the environment > addProperty :: Id -> ImperativeStatement -> ISConvMonad () > addProperty nm body@(ISProperty pos _) = do > state <- get -> let props@(p:ps) = issProperties state +> let props = issProperties state +> (p, ps) = unconsOrErr "CVParserAssertion.addProperty: missing frame" props > case findProp nm props of > Nothing -> put $ state {issProperties = (M.insert nm body p):ps} > Just (ISProperty prevPos _) -> throwError $ [(pos, EMultipleDecl (pvpString nm) prevPos)] diff --git a/src/comp/Parser/BSV/CVParserCommon.lhs b/src/comp/Parser/BSV/CVParserCommon.lhs index 264f5e571..beee98e36 100644 --- a/src/comp/Parser/BSV/CVParserCommon.lhs +++ b/src/comp/Parser/BSV/CVParserCommon.lhs @@ -33,7 +33,7 @@ > import CVPrint > import qualified SEMonad > import Pragma -> import Util (headOrErr, set_insertMany, toMaybe, apRight) +> import Util (headOrErr, unconsOrErr, set_insertMany, toMaybe, apRight) type of the BSV parser @@ -1277,11 +1277,12 @@ saying whether or not the declaration is local > declare pos var typ preds = do > state <- get > let decls = issDeclared state +> decls' = case decls of +> (d:ds) -> let declInfo = (pos, getIdProps var, typ, preds) +> in (M.insert var declInfo d):ds +> _ -> internalError "CVParserCommon.declare: missing decl frame" > nextState warns = -> state { issDeclared = -> (let d:ds = decls -> declInfo = (pos, getIdProps var, typ, preds) -> in (M.insert var declInfo d):ds), +> state { issDeclared = decls', > issWarnings = reverse warns ++ issWarnings state } > in case findDecl var decls of > (Nothing,_) -> put $ nextState [] @@ -1331,7 +1332,8 @@ saying whether or not the declaration is local > assign :: Position -> Id -> AssignmentType -> ISConvMonad () > assign pos var atype = modify -> $ \state -> let a:as = issAssigned state +> $ \state -> let (a, as) = unconsOrErr "CVParserCommon.assign: missing decl frame" $ +> (issAssigned state) > in state { issAssigned = (M.insert var (pos, atype) a):as} > isAssigned :: Id -> ISConvMonad Bool diff --git a/src/comp/Parser/BSV/CVParserImperative.lhs b/src/comp/Parser/BSV/CVParserImperative.lhs index f2588ca4b..6b1f59e18 100644 --- a/src/comp/Parser/BSV/CVParserImperative.lhs +++ b/src/comp/Parser/BSV/CVParserImperative.lhs @@ -1229,7 +1229,6 @@ endfunction > isUnsync (ISBVI _ (BVI_unsync _)) = True > isUnsync _ = False - > mkVMethodConflictInfo :: [([Id], MethodConflictOp, [Id])] -> VMethodConflictInfo > mkVMethodConflictInfo scheds = > let f b = [(i1,i2) @@ -1491,44 +1490,44 @@ some of these restrictions could be lifted if we made the compiler more clever Extract each type of statement, making sure to preserve the order -> let (in_clocks, bvis2) = -> apFst (map (\ (ISBVI _ (BVI_input_clock c)) -> c)) $ -> partition isInputClock bvis1 -> (out_clocks, bvis3) = -> apFst (map (\ (ISBVI _ (BVI_output_clock c)) -> c)) $ -> partition isOutputClock bvis2 -> (ancestors, bvis4) = -> apFst (map (\ (ISBVI _ (BVI_ancestor a)) -> a)) $ -> partition isAncestor bvis3 -> (familys, bvis5) = -> apFst (map (\ (ISBVI _ (BVI_family a)) -> a)) $ -> partition isFamily bvis4 -> (in_resets, bvis6) = -> apFst (map (\ (ISBVI _ (BVI_input_reset a)) -> a)) $ -> partition isInputReset bvis5 -> (out_resets, bvis7) = -> apFst (map (\ (ISBVI _ (BVI_output_reset a)) -> a)) $ -> partition isOutputReset bvis6 -> (args, bvis8) = -> -- parameters in particular need to remain in order, -> -- because instantiaion in v95 syntax uses positional args -> apFst (map (\ (ISBVI _ (BVI_arg a)) -> a)) $ -> partition isArg bvis7 -> (methods, bvis9) = -> apFst (map (\ (ISBVI _ (BVI_method a)) -> a)) $ -> partition isMethod bvis8 -> (ifcs, bvis10) = -> apFst (map (\ (ISBVI _ (BVI_interface a)) -> a)) $ -> partition isInterface bvis9 -> (schedules, bvis11) = -> apFst (map (\ (ISBVI p (BVI_schedule a)) -> (p,a))) $ -> partition isSchedule bvis10 -> (paths, bvis12) = -> apFst (map (\ (ISBVI _ (BVI_path a)) -> a)) $ -> partition isPath bvis11 -> (unsyncs, bvis13) = -> apFst (map (\ (ISBVI _ (BVI_unsync a)) -> a)) $ -> partition isUnsync bvis12 +> let (bvi_in_clocks, bvis2) = partition isInputClock bvis1 +> in_clocks = [ c | (ISBVI _ (BVI_input_clock c)) <- bvi_in_clocks ] +> +> (bvi_out_clocks, bvis3) = partition isOutputClock bvis2 +> out_clocks = [ c | (ISBVI _ (BVI_output_clock c)) <- bvi_out_clocks ] +> +> (bvi_ancestors, bvis4) = partition isAncestor bvis3 +> ancestors = [ a | (ISBVI _ (BVI_ancestor a)) <- bvi_ancestors ] +> +> (bvi_familys, bvis5) = partition isFamily bvis4 +> familys = [ f | (ISBVI _ (BVI_family f)) <- bvi_familys ] +> +> (bvi_in_resets, bvis6) =partition isInputReset bvis5 +> in_resets = [ r | (ISBVI _ (BVI_input_reset r)) <- bvi_in_resets ] +> +> (bvi_out_resets, bvis7) = partition isOutputReset bvis6 +> out_resets = [ r | (ISBVI _ (BVI_output_reset r)) <- bvi_out_resets ] +> +> -- parameters in particular need to remain in order, +> -- because instantiaion in v95 syntax uses positional args +> (bvi_args, bvis8) = partition isArg bvis7 +> args = [ a | (ISBVI _ (BVI_arg a)) <- bvi_args ] +> +> (bvi_methods, bvis9) = partition isMethod bvis8 +> methods = [ m | (ISBVI _ (BVI_method m)) <- bvi_methods ] +> +> (bvi_ifcs, bvis10) = partition isInterface bvis9 +> ifcs = [ i | (ISBVI _ (BVI_interface i)) <- bvi_ifcs ] +> +> (bvi_schedules, bvis11) = partition isSchedule bvis10 +> schedules = [ (p, s) | (ISBVI p (BVI_schedule s)) <- bvi_schedules ] +> +> (bvi_paths, bvis12) = partition isPath bvis11 +> paths = [ p | (ISBVI _ (BVI_path p)) <- bvi_paths ] +> +> (bvi_unsyncs, bvis13) = partition isUnsync bvis12 +> unsyncs = [ u | (ISBVI _ (BVI_unsync u)) <- bvi_unsyncs ] +> > when (not (null bvis13)) > (internalError "convImperativeStmtsToCStmts:ISBVI(2)") @@ -1715,8 +1714,8 @@ Extract each type of statement, making sure to preserve the order > mkBasicDef (\ e -> cVApply idFromActionValue_ [e]) n sn is b > mkBSVIfc (name,constr,ss) = -> let ms = map (\ (ISBVI _ (BVI_method a)) -> a) (filter isMethod ss) -> is = map (\ (ISBVI _ (BVI_interface a)) -> a) (filter isInterface ss) +> let ms = [ m | (ISBVI _ (BVI_method m)) <- ss ] +> is = [ i | (ISBVI _ (BVI_interface i)) <-ss ] > mcs = methodClauses ms > ics = map mkBSVIfc is > clss = mcs++ics @@ -2321,7 +2320,7 @@ to uniquify them. > cvtErr pos EForbiddenLetFn > convImperativeStmtsToCDefns (ISEqual pos (Right var) value : rest) = > do di <- getDeclInfo var -> let (Just (mdeclType, ps)) = di +> let (mdeclType, ps) = fromJustOrErr "convImperativeStmtsToCDefns" di > qualType = CQType ps (fromJust mdeclType) > cls = [CClause [] [] value] > def = if isNothing mdeclType diff --git a/src/comp/Parser/Classic/CParser.hs b/src/comp/Parser/Classic/CParser.hs index 0a23751fd..a1fb2560e 100644 --- a/src/comp/Parser/Classic/CParser.hs +++ b/src/comp/Parser/Classic/CParser.hs @@ -368,8 +368,7 @@ pIfcPragmas = ||! literal (mkFString "always_enabled") .> [PIAlwaysEnabled ] where varString = varcon >>- getIdString - varcon = var ||! con ||! string >>- - \ (CLit (CLiteral p (LString s))) -> mkId p (mkFString s) + varcon = var ||! con ||! pStringAsId pQStructField :: CParser CField @@ -597,7 +596,10 @@ pAPat = pVarIdOrU `into` (\ mi -> Left pos -> CPAny pos )) ||! pConId >>- (\i -> CPCon i []) ||! lp +.+ sepBy pPat (l L_comma) +.. rp >>> pMkTuple - ||! numericLit >>- (\ (CLit l) -> CPLit l) + ||! numericLit >>- litToPLit + where + litToPLit (CLit l) = CPLit l + litToPLit _ = internalError "CParser.pAPat: litToPLit" pPField :: CParser (Id, CPat) pPField = pFieldId `into` \ i -> @@ -629,8 +631,7 @@ pPragma = l L_lpragma ..+ pPragma' +.. l L_rpragma ||! literal (mkFString "deprecate") ..+ eq ..+ varString >>- PPdeprecate properties = literal (mkFString "properties") varString = varcon >>- getIdString - varcon = var ||! con ||! string >>- - \ (CLit (CLiteral p (LString s))) -> mkId p (mkFString s) + varcon = var ||! con ||! pStringAsId pRulePragma :: CParser RulePragma pRulePragma = l L_lpragma ..+ pRulePragma' +.. l L_rpragma @@ -977,6 +978,9 @@ string = lcp "" (\p x->case x of L_string s -> Just (CLit (CLiter pString :: CParser String pString = lcp "" (\p x->case x of L_string s -> Just s; _ -> Nothing) +pStringAsId :: CParser Id +pStringAsId = lcp "" (\p x->case x of L_string s -> Just (mkId p (mkFString s)); _ -> Nothing) + char :: CParser CExpr char = lcp "" (\p x -> case x of L_char c -> Just (CLit (CLiteral p (LChar c))); _ -> Nothing) diff --git a/src/comp/PreIds.hs b/src/comp/PreIds.hs index 4a1cfcb7c..192621e27 100644 --- a/src/comp/PreIds.hs +++ b/src/comp/PreIds.hs @@ -1,10 +1,11 @@ module PreIds where + +import Util(headOrErr, take2OrErr, take3OrErr) import Position import PreStrings import Id import FStringCompat(FString) - -- | Identifier without a position mk_no :: FString -> Id mk_no fs = mkId noPosition fs @@ -475,6 +476,16 @@ tmpTyNumIds, tmpTyVarIds :: [Id] tmpTyNumIds = map (enumId "tnum" noPosition) [4000000..] tmpTyVarIds = map (enumId "v" noPosition) [100..] +-- For avoiding warnings about nonexhaustive pattern matching +take1tmpVarIds :: Id +take1tmpVarIds = headOrErr "take1tmpVarIds" tmpVarIds + +take2tmpVarIds :: (Id, Id) +take2tmpVarIds = take2OrErr "take2tmpVarIds" tmpVarIds + +take3tmpVarIds :: (Id, Id, Id) +take3tmpVarIds = take3OrErr "take3tmpVarIds" tmpVarIds + -- | Used by iExpand idPrimEQ, idPrimULE, idPrimULT, idPrimSLE, idPrimSLT :: Id idPrimEQ = prelude_id_no fsPrimEQ diff --git a/src/comp/SAL.hs b/src/comp/SAL.hs index 1d9252d86..a4087e663 100644 --- a/src/comp/SAL.hs +++ b/src/comp/SAL.hs @@ -369,8 +369,9 @@ ppFieldDef d (i, e) = pPrint d 0 i <+> text ":=" <+> pPrint d 0 e ppVarDecls :: PDetail -> [(SId, SType)] -> Doc ppVarDecls d [] = internalError ("SAL.ppVarDecls empty") ppVarDecls d as = - let as' = map (\ its@((_,t):_) -> (map fst its, t)) $ - groupBy eqSnd as + let as' = let getInfo its@((_,t):_) = (map fst its, t) + getInfo _ = internalError "SAL.ppVarDecls getInfo" + in map getInfo (groupBy eqSnd as) ppArg (is, t) = commaSep (map (pPrint d 0) is) <+> colon <+> pPrint d 0 t in lparen <> commaSep (map ppArg as') <> rparen diff --git a/src/comp/SimCCBlock.hs b/src/comp/SimCCBlock.hs index 2ab42ebe1..64b9cf821 100644 --- a/src/comp/SimCCBlock.hs +++ b/src/comp/SimCCBlock.hs @@ -60,7 +60,8 @@ import qualified Data.Set as S import IntLit import IntegerUtil(aaaa) import PPrint hiding (char, int) -import Util(itos, headOrErr, initOrErr, lastOrErr, snd3, makePairs, concatMapM) +import Util(itos, headOrErr, initOrErr, lastOrErr, unconsOrErr, + snd3, makePairs, concatMapM) import Eval(Hyper(..)) import ErrorUtil(internalError) @@ -386,7 +387,8 @@ aPortIdToC :: AId -> CCExpr aPortIdToC id = let (qs, v) = adjustInstQuals id v' = pfxPort ++ v - (p:ps) = qs ++ [v'] + (p, ps) = unconsOrErr "SimCCBlock.aPortIdToC" $ + qs ++ [v'] in foldl cDot (var p) ps aUnqualPortIdToString :: AId -> String @@ -401,7 +403,8 @@ aParamIdToC :: AId -> CCExpr aParamIdToC id = let (qs, v) = adjustInstQuals id v' = pfxParam ++ v - (p:ps) = qs ++ [v'] + (p, ps) = unconsOrErr "SimCCBlock.aParamIdToC" $ + qs ++ [v'] in foldl cDot (var p) ps -- convert an AId for a param into a CCFragment with full path qualification @@ -413,7 +416,8 @@ aDefIdToC :: AId -> CCExpr aDefIdToC id = let (qs, v) = adjustInstQuals id v' = pfxDef ++ v - (p:ps) = qs ++ [v'] + (p, ps) = unconsOrErr "SimCCBlock.aDefIdToC" $ + qs ++ [v'] in foldl cDot (var p) ps aUnqualDefIdToString :: AId -> String @@ -434,7 +438,8 @@ aInstMethIdToC instId methId = aInstIdToC :: AId -> CCExpr aInstIdToC id = let (qs, v) = adjustInstQuals id - (p:ps) = qs ++ (if (null v) then [] else [pfxInst ++ v]) + (p, ps) = unconsOrErr "SimCCBlock.aInstIdToC" $ + qs ++ (if (null v) then [] else [pfxInst ++ v]) in foldl cDot (var p) ps aUnqualInstIdToString :: AId -> String @@ -464,7 +469,8 @@ aRuleIdToC id = let (qs, v) = adjustInstQuals id -- rule names need no additional prefix v' = v - (p:ps) = qs ++ [v'] + (p, ps) = unconsOrErr "SimCCBlock.aRuleIdToC" $ + qs ++ [v'] in foldl cDot (var p) ps -- convert the unique Int for a clock gate into a CCFragment referencing diff --git a/src/comp/SimCOpt.hs b/src/comp/SimCOpt.hs index 7b87e5557..08d34bb0b 100644 --- a/src/comp/SimCOpt.hs +++ b/src/comp/SimCOpt.hs @@ -214,11 +214,14 @@ moveDefsOntoStack flags instmodmap (blocks,scheds) = segs = filter (/=".") $ split (condense (oneOf ".")) q name = intercalate "_" $ (map ("INST_"++) segs) ++ ["DEF_" ++ b] in setIdBaseString (unQualId aid) name + btype_lookup i = case M.lookup i btype_map of + Just ty -> ty + _ -> internalError "SimCOpt.moveDefsOntoStack btype_lookup" moveDefs (Just sbid) fn = -- move within block let fname = sf_name fn new_defs = [ SFSDef isPort (ty,aid) Nothing | (_,aid) <- M.findWithDefault [] ((Just sbid),fname) move_map - , let (Just ty) = M.lookup (sbid,aid) btype_map + , let ty = btype_lookup (sbid,aid) , let isPort = S.member (sbid,aid) port_set ] body = new_defs ++ (sf_body fn) @@ -229,7 +232,7 @@ moveDefsOntoStack flags instmodmap (blocks,scheds) = | qual_id <- S.toList qids ] | (sbid,aid) <- M.findWithDefault [] (Nothing,fname) move_map - , let (Just ty) = M.lookup (sbid,aid) btype_map + , let ty = btype_lookup (sbid,aid) , let isPort = S.member (sbid,aid) port_set , let qids = M.findWithDefault S.empty (sbid, aid) sched_qids ] diff --git a/src/comp/SimExpand.hs b/src/comp/SimExpand.hs index 4011bbb94..027996c22 100644 --- a/src/comp/SimExpand.hs +++ b/src/comp/SimExpand.hs @@ -1289,7 +1289,10 @@ combineDomainInfoMap inst avinst ds -> -- substitute each (child,parent) clock pair -- to create the new domain info - let (_, Just (parent_dom_id,_)) = head ds + let parent_dom_id = + case ds of + ((_, Just (i,_)):_) -> i + _ -> internalError "combineDomainInfoMap substDomain" ps = [ (c,p) | (c, Just(_,p)) <- ds ] sub dom_info (child_clk,parent_clk) = substInputClockInDomainInfo child_clk diff --git a/src/comp/SimPrimitiveModules.hs b/src/comp/SimPrimitiveModules.hs index 7f46f9548..c0a05b876 100644 --- a/src/comp/SimPrimitiveModules.hs +++ b/src/comp/SimPrimitiveModules.hs @@ -172,67 +172,58 @@ bit_count 0 = 0 bit_count x = 1 + (bit_count (x `div` 2)) fifoType :: String -> String -> NamingFn -fifoType "FIFO1" prim args@((ASInt _ _ sz):_) = +fifoType "FIFO1" prim [width@(ASInt _ _ sz), guarded] = let ty_doc = pPrint PDReadable 0 (bitsType (ilValue sz) CTunsigned) doc = (text prim) <> (text "<") <> ty_doc <> (text ">") - [width, guarded] = args in (render doc, [width, aNat 1, guarded, aNat 0]) fifoType "FIFO10" prim args = fifoType "FIFO1" prim ((aNat 0):args) -fifoType "FIFO2" prim args@((ASInt _ _ sz):_) = +fifoType "FIFO2" prim [width@(ASInt _ _ sz), guarded] = let ty_doc = pPrint PDReadable 0 (bitsType (ilValue sz) CTunsigned) doc = (text prim) <> (text "<") <> ty_doc <> (text ">") - [width, guarded] = args in (render doc, [width, aNat 2, guarded, aNat 0]) fifoType "FIFO20" prim args = fifoType "FIFO2" prim ((aNat 0):args) -fifoType "SizedFIFO" prim args@((ASInt _ _ sz):_) = +fifoType "SizedFIFO" prim [width@(ASInt _ _ sz), depth, _, guarded] = let ty_doc = pPrint PDReadable 0 (bitsType (ilValue sz) CTunsigned) doc = (text prim) <> (text "<") <> ty_doc <> (text ">") - [width, depth, _, guarded] = args in (render doc, [width, depth, guarded, aNat 0]) fifoType "SizedFIFO0" prim args = fifoType "SizedFIFO" prim ((aNat 0):args) -fifoType "FIFOL1" prim args@((ASInt _ _ sz):_) = +fifoType "FIFOL1" prim [width@(ASInt _ _ sz)] = let ty_doc = pPrint PDReadable 0 (bitsType (ilValue sz) CTunsigned) doc = (text prim) <> (text "<") <> ty_doc <> (text ">") - [width] = args in (render doc, [width, aNat 1, aNat 0, aNat 1]) fifoType "FIFOL10" prim args = fifoType "FIFOL1" prim ((aNat 0):args) -fifoType "FIFOL2" prim args@((ASInt _ _ sz):_) = +fifoType "FIFOL2" prim [width@(ASInt _ _ sz)] = let ty_doc = pPrint PDReadable 0 (bitsType (ilValue sz) CTunsigned) doc = (text prim) <> (text "<") <> ty_doc <> (text ">") - [width] = args in (render doc, [width, aNat 2, aNat 0, aNat 1]) fifoType "FIFOL20" prim args = fifoType "FIFOL2" prim ((aNat 0):args) -fifoType "SizedFIFOL" prim args@((ASInt _ _ sz):_) = +fifoType "SizedFIFOL" prim [width@(ASInt _ _ sz), depth, _] = let ty_doc = pPrint PDReadable 0 (bitsType (ilValue sz) CTunsigned) doc = (text prim) <> (text "<") <> ty_doc <> (text ">") - [width, depth, _] = args in (render doc, [width, depth, aNat 0, aNat 1]) fifoType "SizedFIFOL0" prim args = fifoType "SizedFIFOL" prim ((aNat 0):args) -fifoType "SyncFIFO" prim args@((ASInt _ _ sz):_) = +fifoType "SyncFIFO" prim [width@(ASInt _ _ sz), depth, _] = let ty_doc = pPrint PDReadable 0 (bitsType (ilValue sz) CTunsigned) idx_bits = bit_count (ilValue sz) idx_doc = pPrint PDReadable 0 (bitsType idx_bits CTunsigned) doc = (text prim) <> (text "<") <> ty_doc <> comma <> idx_doc <> (text ">") - [width, depth, _] = args in (render doc, [width, depth, aNat 0]) fifoType "SyncFIFO0" prim args = fifoType "SyncFIFO" prim ((aNat 0):args) -fifoType "SyncFIFO1" prim args@((ASInt _ _ sz):_) = +fifoType "SyncFIFO1" prim [width@(ASInt _ _ sz)] = let ty_doc = pPrint PDReadable 0 (bitsType (ilValue sz) CTunsigned) idx_bits = bit_count (ilValue sz) idx_doc = pPrint PDReadable 0 (bitsType idx_bits CTunsigned) doc = (text prim) <> (text "<") <> ty_doc <> comma <> idx_doc <> (text ">") - [width] = args in (render doc, [width, aNat 1, aNat 0]) fifoType "SyncFIFO10" prim args = fifoType "SyncFIFO1" prim ((aNat 0):args) -fifoType "SyncFIFOLevel" prim args@((ASInt _ _ sz):_) = +fifoType "SyncFIFOLevel" prim [width@(ASInt _ _ sz), depth, _] = let ty_doc = pPrint PDReadable 0 (bitsType (ilValue sz) CTunsigned) idx_bits = bit_count (ilValue sz) idx_doc = pPrint PDReadable 0 (bitsType idx_bits CTunsigned) doc = (text prim) <> (text "<") <> ty_doc <> comma <> idx_doc <> (text ">") - [width, depth, _] = args in (render doc, [width, depth, aNat 1]) fifoType "SyncFIFOLevel0" prim args = fifoType "SyncFIFOLevel" prim ((aNat 0):args) fifoType mod prim args = internalError $ mkErr mod prim "FIFO width and depth arguments" args diff --git a/src/comp/StdPrel.hs b/src/comp/StdPrel.hs index 38bdbbd42..c8a75b0af 100644 --- a/src/comp/StdPrel.hs +++ b/src/comp/StdPrel.hs @@ -16,7 +16,7 @@ module StdPrel( import qualified Bag as B import qualified Data.Set as S -import Util(log2, ordPair, integerSqrt) +import Util(log2, ordPair, integerSqrt, take3OrErr) import Position import ErrorUtil(internalError) import Id @@ -35,7 +35,7 @@ import Unify(mgu) -- ------------------------- v1, v2, v3 :: Id -v1 : v2 : v3 : _ = tmpTyVarIds +(v1, v2, v3) = take3OrErr "StdPrel tmpTyVarIds" tmpTyVarIds tvarh1, tvarh2, tvarh3 :: TyVar tvarh1 = tVarKind v1 KNum diff --git a/src/comp/Synthesize.hs b/src/comp/Synthesize.hs index c4b6e2e22..7c2db3749 100644 --- a/src/comp/Synthesize.hs +++ b/src/comp/Synthesize.hs @@ -159,14 +159,20 @@ toED (ADef i t e props) = do toE :: AExpr -> S AExpr -- XXX bad code toE (APrim aid t p [x,y]) | p == PrimSLE || p == PrimSLT = - let ty@(ATBit n) = aType x + let ty = aType x + n = case ty of + (ATBit sz) -> sz + _ -> internalError "Synthesize.toE PrimSLx: n" c = ASInt defaultAId ty (ilHex (2^(n-1))) x' = APrim aid ty PrimXor [x, c] y' = APrim aid ty PrimXor [y, c] in toE (APrim aid t (if p == PrimSLE then PrimULE else PrimULT) [x',y']) -- XXX bad code toE (APrim aid t@(ATBit n) PrimExtract [e, h, l]) | h /= l && not (isConst h && isConst l) = - let te@(ATBit m) = aType e + let te = aType e + m = case te of + (ATBit sz) -> sz + _ -> internalError "Synthesize.toE PrimExtract: m" e1 | m > n = APrim aid t PrimExtract [e1f, ASInt defaultAId aTNat (ilDec (n-1)), diff --git a/src/comp/SystemVerilogPreprocess.lhs b/src/comp/SystemVerilogPreprocess.lhs index a96522fae..f4508c5d8 100644 --- a/src/comp/SystemVerilogPreprocess.lhs +++ b/src/comp/SystemVerilogPreprocess.lhs @@ -161,26 +161,31 @@ Toplevel scanner function > c:restOfInput ), env, errh, flgs)) > | isWhitespace c = > let -> (ws, cl1:trest) = span (isWhitespace) restOfInput -> orest = if (cl1 /= '`') then -> (cl1:trest) -> else -> let -> (str,_) = (prescanReplace errh trest pos env) -> in -> str -> (ws2, cl:rest) = span (isWhitespace) orest -> delimiter = -> case cl of -> '\"' -> (/= '\"') -> '<' -> (/= '>') +> (ws, restOfInput2) = span (isWhitespace) restOfInput +> restOfInput3 = case restOfInput2 of +> ('`':rest) -> fst (prescanReplace errh rest pos env) +> -- EOF (empty list) will be handled below +> _ -> restOfInput2 +> (ws2, restOfInput4) = span (isWhitespace) restOfInput3 +> (delim1, delim2, restOfInput5) = +> case restOfInput4 of +> ('\"':rest) -> ('\"', '\"', rest) +> ('<':rest) -> ('<', '>', rest) +> -- The following also handles EOF (empty list) > _ -> let pos' = updatePosString pos > ("`include" ++ (c:ws)) > in bsErrorUnsafe errh [(pos', ESVPNoImportDelimiter)] -> (filestr, cr:furtherInput) = span delimiter rest -> newPos = (updatePosString pos ("`include" ++ (c:ws) ++ -> (cl1:ws2) ++ -> (cl:filestr) ++ (cr:[]))) +> (filestr, restOfInput6) = span (/= delim2) restOfInput5 +> furtherInput = +> case restOfInput6 of +> (h:rest) | (h == delim2) -> rest +> -- The following also handles EOF (empty list) +> _ -> -- XXX ESVPNoImportDelimiter isn't quite right +> let pos' = updatePosString pos +> ("`include" ++ (c:ws) ++ (delim1:filestr)) +> in bsErrorUnsafe errh [(pos', ESVPNoImportDelimiter)] +> newPos = updatePosString pos ("`include" ++ (c:ws) ++ ws2 ++ +> (delim1:filestr) ++ [delim2]) > missingFileErr = > bsError errh [(pos, EMissingIncludeFile filestr)] > in @@ -227,16 +232,20 @@ Toplevel scanner function > "timescale","unconnected_drive","undef", "bluespec", > "BLUESPEC"] > acquireblock :: String -> (String,String) -> acquireblock ('/':'/':input) = let -> (line, cr:rest) = span (/= '\n') input -> in -> if ((not (null line)) && (last line) == '\\') then -> let -- non-terminating line comment -> (l,r) = (acquireblock rest) -> in -> ('/':'/':line ++(cr:l),r) -> else -> ([],'/':'/':input) -- line comment which ends it +> acquireblock ('/':'/':input) = +> let +> (line, rest) = span (/= '\n') input +> in +> if ((not (null line)) && (last line) == '\\') then +> -- non-terminating line comment +> case rest of +> (cr:rest') -> let (l,r) = acquireblock rest +> in ('/':'/':line ++(cr:l),r) +> -- EOF +> -- XXX Should this be an error? +> [] -> ('/':'/':line, []) +> else +> ([],'/':'/':input) -- line comment which ends it > acquireblock ('/':'*':input) = > let -- treat like a single line > finishMultiline [] = ([],[]) @@ -540,8 +549,9 @@ Split a comma separated string into a list of parameters while: > ppsplit' False cnt ('`':'l':'i':'n':'e':c:rest) | (isWhitespace c) = > ppsplit' False cnt ('`':'l':'i':'n':'e':rest) > ppsplit' False cnt ('`':'l':'i':'n':'e':'(':rest) = -> let (a:b) = ppsplit' True cnt rest -> in (('`':'l':'i':'n':'e':'(':a):b) +> case ppsplit' True cnt rest of +> (a:b) -> (('`':'l':'i':'n':'e':'(':a):b) +> _ -> internalError ("ppsplit_params: `line is missing closing paren") > ppsplit' False cnt [] = [] > ppsplit' False cnt ('(':rest) = > cons_fst '(' (ppsplit' False (cnt + 1) rest) diff --git a/src/comp/SystemVerilogScanner.lhs b/src/comp/SystemVerilogScanner.lhs index 303e35ef2..e71d3f27a 100644 --- a/src/comp/SystemVerilogScanner.lhs +++ b/src/comp/SystemVerilogScanner.lhs @@ -310,13 +310,21 @@ line Pos directive. Emitted by the preprocessor One day the gods will smite me for this. +> -- XXX Errors should be better handled (GitHub issue #584) > scanLinePosDirective ::Position -> Scanner > scanLinePosDirective ipos state@(ScannerState (pos,input)) = -> let (directive, _:restOfInput) = span (/= ')') input +> let (directive, mParenAndRestOfInput) = span (/= ')') input +> restOfInput = case mParenAndRestOfInput of +> (')':rest) -> rest +> _ -> internalError "scanLinePosDirective: missing close paren" > list = Data.List.groupBy (\x -> \y -> (x /= ',') && (y /= ',')) directive > param_list = map (filter (\x -> (not (isWhitespace x)))) > (filter ( /= ",") list) -> (f:l:c:_ {-level-}:_) = param_list +> -- Expect four arguments (file, line, column, and level) +> -- but only use the first three +> (f, l, c) = case param_list of +> (a1:a2:a3:_:_) -> (a1, a2, a3) +> _ -> internalError "scanLinePosDirective: too few arguments" > in > scanMain (ScannerState (updatePosFileLineCol pos (mkFString f) > (read l) (read c), restOfInput)) diff --git a/src/comp/TCheck.hs b/src/comp/TCheck.hs index 9454670d8..e56a90498 100644 --- a/src/comp/TCheck.hs +++ b/src/comp/TCheck.hs @@ -817,7 +817,10 @@ tiExpr as td exp@(CmoduleVerilog name ui clks rsts args fields sch ps) = do -- tyM1 <- mapM (\ e -> newTVar "tiExpr CmoduleVerilog 4" KStar e) es -- tyM2 <- mapM (\ t -> newTVar "tiExpr CmoduleVerilog 5" KStar t) ts case leftCon (expandSyn (apSub s v)) of - Just ti | mfs /= Nothing -> + Just ti | (Just fs0) <- getIfcFields ti sy -> + let fs = {- trace ("fields:" ++ ppReadable fs0) $ -} map unQualId fs0 + ty = foldr fn td ts + in -- check for extra fields first case fieldnames \\ fs of i:_ -> err (getIdPosition i, EForeignModNotField @@ -831,10 +834,6 @@ tiExpr as td exp@(CmoduleVerilog name ui clks rsts args fields sch ps) = do let e' = CmoduleVerilogT ty name' ui clks rsts ses' fields' sch ps return (eq_ps ++ nps {- ++ concat pss -} ++ concat qss, e') - where mfs = getIfcFields ti sy - Just fs0 = mfs - fs = {- trace ("fields:" ++ ppReadable fs0) $ -} map unQualId fs0 - ty = foldr fn td ts _ -> err (getPosition exp, ENotAnInterface) tiExpr as td exp@(CForeignFuncC link_id wrap_cqt) = do @@ -1391,10 +1390,9 @@ taskCheckSWrite as td f es = -- and an invocation of the write method on the supplied interface. createAVExpr :: [Assump] -> Type -> CExpr -> [CExpr] -> TI CExpr createAVExpr _ _ f [] = err (getPosition f, (EMissingFileArgument (ppReadable f) "interface" "first")) -createAVExpr as td f (dest:es) = +createAVExpr as td f@(CVar task) (dest:es) = do let pos = (getPosition f) - let (CVar task) = f let id_av = toAVId(task) v <- newTVar "createAVExpr" KStar f _ <- tiExpr as v dest @@ -1410,7 +1408,9 @@ createAVExpr as td f (dest:es) = Just x -> return x let (_ :>: (Forall _ qt)) = fi_assump info let (_ :=> tt) = inst args qt - let ((_:rest), _) = getArrows tt + let rest = case getArrows tt of + ((_:r), _) -> r + _ -> internalError "TCheck.createAVExpr: getArrows" t <- case (rest) of [x] -> return x _ -> err (pos, (EMissingFileArgument (ppReadable f) "interface (with an _write method)" "first" )) @@ -1420,6 +1420,7 @@ createAVExpr as td f (dest:es) = (CTaskApply (CVar id_av) es)), (CSExpr Nothing (Cwrite pos dest (CVar id_new)))]) return expr +createAVExpr _ _ _ _ = internalError "TCheck.createAVExpr" createIdNew :: CExpr -> Position -> TI Id createIdNew dest pos = @@ -1899,7 +1900,9 @@ tiStmts' chke mon mt as td (CSBindT (CPVar i) maybeName pprops (CQType [] ty) e mapM_ kindCheckBV bvs -- check that there are no free vars in ty unless (null fvs) $ - let TyVar v _ _ : _ = fvs + let v = case fvs of + (TyVar v _ _ : _) -> v + _ -> internalError "TCheck.tiStmts' CSBindT CPVar: fvs" in err (getPosition v, EUnboundTyVar (pfpString v)) tiStmtBind chke mon mt as td i maybeName pprops e ss ty tiStmts' chke mon mt as td (CSBindT p name pprops qt e : ss) = do @@ -2075,8 +2078,12 @@ tiField1 as rt (f, e) = do --posCheck "F" f i' <- newVar (getIdPosition f) "tiField1" -- trace ("tiField1 " ++ ppReadable (f, i')) $ return () - let fvs = map (\ (TVar v) -> v) (drop n xts) - TAp _ ft' = ft + let fvs = let getTyVar (TVar v) = v + getTyVar _ = internalError "TCheck.tiField1: fvs" + in map getTyVar (drop n xts) + ft' = case ft of + TAp _ t -> t + _ -> internalError "TCheck.tiField1: ft'" fsc = quantify fvs (apSub s (qs :=> ft')) -- if "e" is just a wrapper for a tiExpl anyway, call tiExpl on -- the wrapped def (see comments for tiExpr on Cinterface) @@ -2580,7 +2587,9 @@ tiExpl''' as0 i sc alts me (oqt@(oqs :=> ot), vts) = do nsc = sc' -- The dictionary names of the predicates - vs = map (\ (EPred (CVar i) _) -> i) eqs + vs = let getId (EPred (CVar i) _) = i + getId _ = internalError "TCheck.tiExpl''': vs getId" + in map getId eqs -- The predicates which will be returned, to be handled by the -- enclosing binding. It includes the deferred predicates "ds" @@ -2935,7 +2944,10 @@ tiImpls recursive as ibs = do let mkFreshVar v = newTVar ("tiImpls fresh") (kind v) v vs_bound_here <- mapM mkFreshVar gs_used_here -- the same list, but as TyVar - let vts_bound_here = map (\ (TVar v) -> v) vs_bound_here + let vts_bound_here = + let getTyVar (TVar v) = v + getTyVar _ = internalError "TCheck.tiImpls: vts_bound_here getTyVar" + in map getTyVar vs_bound_here -- a mapping from the old names to the new names -- (need to apply this subst to everything -- types and exprs) -- (CSubst was extended to support TVar specifically for this) diff --git a/src/comp/Util.hs b/src/comp/Util.hs index 26141cb8f..3d091fdf2 100644 --- a/src/comp/Util.hs +++ b/src/comp/Util.hs @@ -162,6 +162,17 @@ lastOrErr _ [x] = x lastOrErr err (_:xs) = lastOrErr err xs lastOrErr err [] = internalError err +unconsOrErr :: String -> [elem] -> (elem, [elem]) +unconsOrErr _ (elt:rest) = (elt, rest) +unconsOrErr err [] = internalError err + +take2OrErr :: String -> [elem] -> (elem, elem) +take2OrErr _ (x1:x2:_) = (x1, x2) +take2OrErr err _ = internalError err + +take3OrErr :: String -> [elem] -> (elem, elem, elem) +take3OrErr _ (x1:x2:x3:_) = (x1, x2, x3) +take3OrErr err _ = internalError err rTake, rDrop :: Int -> [a] -> [a] rTake n = reverse . take n . reverse @@ -300,7 +311,10 @@ mapThd f xyzs = [(x, y, f z) | (x, y, z) <- xyzs] joinByFst :: (Ord a) => [(a, b)] -> [(a, [b])] joinByFst = - map (\ xys@((x,_):_) -> (x, map snd xys)) . + let joinSameFirst xys@((x,_):_) = (x, map snd xys) + joinSameFirst _ = internalError "joinByFst" + in + map joinSameFirst . groupBy (\ (x,_) (y,_) -> x==y) . sortBy (\ (x,_) (y,_) -> x `compare` y) @@ -347,6 +361,9 @@ nubByFst :: (Eq a) => [(a, b)] -> [(a, b)] nubByFst xs = nubBy f xs where f a b = (fst a == fst b) +sortPair :: (Ord a) => (a, a) -> (a, a) +sortPair (x, y) = if (y < x) then (y, x) else (x, y) + -- ===== -- List/Either utilities diff --git a/src/comp/VCD.hs b/src/comp/VCD.hs index 4cbeef1db..8d4d567be 100644 --- a/src/comp/VCD.hs +++ b/src/comp/VCD.hs @@ -290,8 +290,10 @@ readChanges (w:ws) = then case (readChanges ws) of (Left err) -> Left err (Right xs) -> Right ((scalar_p w):xs) - else let (w':ws') = ws - mx = if (c == 'b' || c == 'B') + else + case ws of + (w':ws') -> + let mx = if (c == 'b' || c == 'B') then Just (vector_p rest w') else if (c == 'r' || c == 'R') then Just (real_p rest w') @@ -300,6 +302,7 @@ readChanges (w:ws) = (Nothing, _) -> Left (w:ws) (_,Left err) -> Left err (Just x, Right xs) -> Right (x:xs) + _ -> Left (w:ws) -- create an Err command error_p :: String -> [C.ByteString] -> VCDCmd diff --git a/src/comp/bluetcl.hs b/src/comp/bluetcl.hs index 4703a047d..3f73f2d9b 100644 --- a/src/comp/bluetcl.hs +++ b/src/comp/bluetcl.hs @@ -2086,7 +2086,8 @@ getBInstChildren b@(BNode {binst_sub = sub}) = -- mkChildIN :: (String, ABinEitherModInfo) -> Bool -> InstNode -> IO [BInst] mkChildIN _ _ inodep | isSynthP hide inodep = - do let (Just unique) = getSynthName hide inodep + do let unique = fromJustOrErr "bluetcl.mkChildIN: unique" $ + getSynthName hide inodep mminfo <- findModuleByInstance (reverse $ (getIdBaseString $ unique) : binst_synth b) let b_add = addInst b (Just (getIdBaseString $ unique)) (getIdBaseString $ node_name inodep) diff --git a/src/comp/bsc.hs b/src/comp/bsc.hs index 9bde48246..776d65165 100644 --- a/src/comp/bsc.hs +++ b/src/comp/bsc.hs @@ -2192,7 +2192,10 @@ compileCDefToIDef errh flags dumpnames symt ipkg def = t <- dump errh flags t DFtypecheck dumpnames cpkg_chk start flags DFsimplified - let cpkg_simp@(CPackage _ _ _ _ [def'] _) = simplify flags cpkg_chk + let cpkg_simp = simplify flags cpkg_chk + def' = case cpkg_simp of + (CPackage _ _ _ _ [d] _) -> d + _ -> internalError "compileCDefToIDef: unexpected number of defs" t <- dump errh flags t DFsimplified dumpnames cpkg_simp start flags DFinternal diff --git a/src/comp/showrules.hs b/src/comp/showrules.hs index 8f21e0a13..792662efe 100644 --- a/src/comp/showrules.hs +++ b/src/comp/showrules.hs @@ -14,7 +14,7 @@ import Error(internalError, EMsg, WMsg, ErrMsg(..), ErrorHandle, initErrorHandle, exitOK, exitFail, bsErrorNoExit, bsWarning, convErrorTToIO) -import Util(separate) +import Util(separate, headOrErr, fromJustOrErr, unconsOrErr) import IOUtil(getEnvDef) import TopUtils(dfltBluespecDir) import ASyntax @@ -414,7 +414,8 @@ mkMorphState opts instmap hiermap abmis_by_name top_mod = let user_modules = [ (inst,abmi) | (inst,mod) <- M.toList instmap , not (isPrimitiveModule mod) - , let (Just abmi) = M.lookup mod abmimap + , let abmi = fromJustOrErr "mkMorphState: user_modules" $ + M.lookup mod abmimap ] all_rules = [ (inst,rule) | (inst,abmi) <- user_modules @@ -456,7 +457,7 @@ mkMorphState opts instmap hiermap abmis_by_name top_mod = let getRuleActs i r = If (i,(arule_pred r)) (getActs i (arule_actions r)) getActs i [] = [] getActs i ((ACall o m args):acts) = - let (cond:_) = args + let cond = headOrErr "mkMorphState: getActs" args sub_inst = joinName i o m' = setIdQualString m "" sub_acts = case (M.lookup (sub_inst,m') methmap) of @@ -1182,7 +1183,8 @@ formatNovas st = rmap = rule_map st full_names = [ (n, x, xs) | (s,n) <- M.toList rmap - , let (x:xs) = reverse (wordsBy (=='.') s) + , let (x, xs) = unconsOrErr "formalNovas: full_names" $ + reverse (wordsBy (=='.') s) ] lengthen n name [] = internalError "duplicate keys in map!?!?" lengthen n name (x:xs) = (n, x ++ "." ++ name, xs) diff --git a/src/comp/vcdcheck.hs b/src/comp/vcdcheck.hs index 5fc0c983f..7f737754a 100644 --- a/src/comp/vcdcheck.hs +++ b/src/comp/vcdcheck.hs @@ -320,7 +320,7 @@ parseCheckCmd opts s = parse (words s) (_, Nothing, _) -> [Left $ "Error in scanning CRC command -- every time " ++ every] (_, _, Nothing) -> [Left $ "Error in scanning CRC command -- sequence length " ++ for] _ -> [Left $ "Error in scanning CRC command " ++ s] - parse ("CRC":_) = [Left $"CRC command expects 4 arguments " ++ s] + parse ("CRC":_) = [Left $ "CRC command expects 4 arguments " ++ s] parse _ = [Left s] diff --git a/testsuite/bsc.preprocessor/misc/misc.exp b/testsuite/bsc.preprocessor/misc/misc.exp index 6e6571c2a..714a7d28f 100644 --- a/testsuite/bsc.preprocessor/misc/misc.exp +++ b/testsuite/bsc.preprocessor/misc/misc.exp @@ -94,6 +94,6 @@ compile_pass Line_MissingParen_NextLine.bsv # Additional tests for GitHub issue #584 # Should this pass? Should EOF be allowed after final backslash? -compile_pass_bug Define_NonTermComment_EOF.bsv 584 +compile_pass Define_NonTermComment_EOF.bsv # ---------- From a7f98bfe0c64f10f726b5eca86e3ba999a05d4fa Mon Sep 17 00:00:00 2001 From: Julie Schwartz Date: Fri, 4 Aug 2023 20:28:11 +1200 Subject: [PATCH 3/4] Update BSC to compile with GHC 9.6 In version 2.3 of the mtl library, re-export of other modules was removed; so now those other modules need to be imported, if functions from them are needed. To avoid duplicate import when compiling with earlier mtl/GHC versions, the import statements need to explicitly list the functions imported from each module. --- src/comp/ABinUtil.hs | 3 ++- src/comp/ACleanup.hs | 3 ++- src/comp/AConv.hs | 7 +++---- src/comp/AExpr2STP.hs | 4 +++- src/comp/AExpr2Yices.hs | 4 +++- src/comp/AOpt.hs | 4 +++- src/comp/ARankMethCalls.hs | 2 +- src/comp/ASchedule.hs | 3 ++- src/comp/AUses.hs | 3 ++- src/comp/AVeriQuirks.hs | 3 ++- src/comp/ErrorTCompat.hs | 4 +--- src/comp/GenWrap.hs | 3 ++- src/comp/IExpand.hs | 4 +++- src/comp/IExpandUtils.hs | 4 +++- src/comp/ITransform.hs | 4 ++-- src/comp/LambdaCalc.hs | 3 ++- src/comp/LambdaCalcUtil.hs | 3 ++- src/comp/Parser/BSV/CVParserCommon.lhs | 5 +++-- src/comp/Parser/Classic/Warnings.hs | 5 +++-- src/comp/Pred2STP.hs | 3 ++- src/comp/Pred2Yices.hs | 3 ++- src/comp/SAL.hs | 3 ++- src/comp/SimCCBlock.hs | 3 ++- src/comp/Synthesize.hs | 3 ++- src/comp/TIMonad.hs | 4 +++- src/comp/VVerilogDollar.hs | 3 ++- src/comp/bluetcl.hs | 3 ++- 27 files changed, 61 insertions(+), 35 deletions(-) diff --git a/src/comp/ABinUtil.hs b/src/comp/ABinUtil.hs index a9f055d8d..cd0bccf63 100644 --- a/src/comp/ABinUtil.hs +++ b/src/comp/ABinUtil.hs @@ -8,7 +8,8 @@ module ABinUtil ( import Data.List(nub, partition) import Data.Maybe(isJust, fromJust) -import Control.Monad.State +import Control.Monad(when) +import Control.Monad.State(StateT, runStateT, lift, get, put) import ErrorTCompat import Version(bscVersionStr) diff --git a/src/comp/ACleanup.hs b/src/comp/ACleanup.hs index 2c18f3c85..0c660f701 100644 --- a/src/comp/ACleanup.hs +++ b/src/comp/ACleanup.hs @@ -6,7 +6,8 @@ import DisjointTest(DisjointTestState, initDisjointTestState, addADefToDisjointTestState, checkDisjointExprWithCtx) import Data.Maybe import Flags(Flags) -import Control.Monad.State +import Control.Monad(when) +import Control.Monad.State(StateT, evalStateT, liftIO, get, put) import FStringCompat(mkFString) import Position(noPosition) import Id diff --git a/src/comp/AConv.hs b/src/comp/AConv.hs index a1b8d1849..ef2982da5 100644 --- a/src/comp/AConv.hs +++ b/src/comp/AConv.hs @@ -2,9 +2,10 @@ module AConv (aConv, aTypeConv, isLocalAId) where import Util(itos, headOrErr, initOrErr, lastOrErr, log2, concatMapM, makePairs) import qualified Data.Map as M -import Control.Monad.State hiding (forM) import ErrorTCompat -import Control.Monad.Reader hiding (forM) +import Control.Monad(when, liftM, forM, zipWithM) +import Control.Monad.State(StateT, runStateT, gets, get, put) +import Control.Monad.Reader(ReaderT, runReaderT, withReaderT, ask) import PPrint(ppReadable, ppString) import PFPrint(pfpString) import Position @@ -33,8 +34,6 @@ import VModInfo(lookupOutputClockWires, lookupOutputResetWire, import SignalNaming import InstNodes(mkInstTree) -import Data.Traversable(forM) - -- import Wires -- Used by commented-out makeIdMap diff --git a/src/comp/AExpr2STP.hs b/src/comp/AExpr2STP.hs index 92f5d8a23..ce45f26cd 100644 --- a/src/comp/AExpr2STP.hs +++ b/src/comp/AExpr2STP.hs @@ -12,7 +12,9 @@ module AExpr2STP( checkNotEq ) where -import Control.Monad.State +import Control.Monad(when) +import Control.Monad.State(StateT, runStateT, liftIO, + gets, get, put, modify) import qualified Data.Map as M import qualified STP as S diff --git a/src/comp/AExpr2Yices.hs b/src/comp/AExpr2Yices.hs index b55ae91e3..b621930e0 100644 --- a/src/comp/AExpr2Yices.hs +++ b/src/comp/AExpr2Yices.hs @@ -12,7 +12,9 @@ module AExpr2Yices( checkNotEq ) where -import Control.Monad.State +import Control.Monad(when) +import Control.Monad.State(StateT, runStateT, liftIO, + gets, get, put, modify) import qualified Data.Map as M import qualified Yices as Y import Data.Word(Word32) diff --git a/src/comp/AOpt.hs b/src/comp/AOpt.hs index 869529552..e6fe65589 100644 --- a/src/comp/AOpt.hs +++ b/src/comp/AOpt.hs @@ -11,7 +11,9 @@ module AOpt(aOpt, ) where -import Control.Monad.State +import Control.Monad(when, foldM, zipWithM) +import Control.Monad.State(State, StateT, evalState, evalStateT, liftIO, + gets, get, put) import Data.List(sortBy, genericLength, sort, transpose, partition, groupBy, nub) import ListUtil(mapFst) import qualified Data.Map as M diff --git a/src/comp/ARankMethCalls.hs b/src/comp/ARankMethCalls.hs index f02e4ad2c..9826b41b9 100644 --- a/src/comp/ARankMethCalls.hs +++ b/src/comp/ARankMethCalls.hs @@ -2,7 +2,7 @@ module ARankMethCalls(aRankMethCalls) where import Data.List import Data.Maybe -import Control.Monad.State +import Control.Monad(when) import ASyntax import FStringCompat diff --git a/src/comp/ASchedule.hs b/src/comp/ASchedule.hs index a9e6f1b4b..b44191390 100644 --- a/src/comp/ASchedule.hs +++ b/src/comp/ASchedule.hs @@ -20,7 +20,8 @@ import Prelude hiding ((<>)) import Data.List import Data.Maybe import ErrorTCompat -import Control.Monad.State +import Control.Monad(when, foldM) +import Control.Monad.State(StateT, runStateT, lift, get, put) import System.IO.Unsafe import Debug.Trace(traceM) import qualified Data.Map as M diff --git a/src/comp/AUses.hs b/src/comp/AUses.hs index 0c680e83f..bfdd321a7 100644 --- a/src/comp/AUses.hs +++ b/src/comp/AUses.hs @@ -78,7 +78,8 @@ import PVPrint import ErrorUtil(internalError) import Prim import IntLit -import Control.Monad.State.Strict +import Control.Monad(liftM, mapAndUnzipM) +import Control.Monad.State.Strict(State, runState, get, put) -- import Debug.Trace diff --git a/src/comp/AVeriQuirks.hs b/src/comp/AVeriQuirks.hs index 1648ea516..c09ab72bb 100644 --- a/src/comp/AVeriQuirks.hs +++ b/src/comp/AVeriQuirks.hs @@ -12,7 +12,8 @@ import Flags(Flags, keepAddSize, removePrimModules, useNegate, readableMux) import Id import PreIds(idUnsigned) import FStringCompat(mkFString) -import Control.Monad.State +import Control.Monad(when) +import Control.Monad.State(State, evalState, gets, get, put) import qualified Data.Map as M import Prim import Pragma(defPropsHasNoCSE) diff --git a/src/comp/ErrorTCompat.hs b/src/comp/ErrorTCompat.hs index 9c7fc619a..b5f7d3811 100644 --- a/src/comp/ErrorTCompat.hs +++ b/src/comp/ErrorTCompat.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE CPP #-} module ErrorTCompat ( ErrorT, runErrorT, - MonadError(..), - lift + MonadError(..) ) where import Control.Monad.Except diff --git a/src/comp/GenWrap.hs b/src/comp/GenWrap.hs index a9d89a6f9..93f4066dd 100644 --- a/src/comp/GenWrap.hs +++ b/src/comp/GenWrap.hs @@ -11,7 +11,8 @@ import Prelude hiding ((<>)) import Data.List(nub, (\\), find) import ErrorTCompat -import Control.Monad.State +import Control.Monad(when, foldM, filterM, zipWithM, mapAndUnzipM) +import Control.Monad.State(StateT, runStateT, lift, gets, get, put) import PFPrint import Position(Position, noPosition, getPositionLine, cmdPosition) import Error(internalError, EMsg, EMsgs(..), ErrMsg(..), ErrorHandle, bsError) diff --git a/src/comp/IExpand.hs b/src/comp/IExpand.hs index 100a61e6f..4943376dd 100644 --- a/src/comp/IExpand.hs +++ b/src/comp/IExpand.hs @@ -22,8 +22,10 @@ import Data.Maybe import Data.Foldable(foldrM) import Numeric(showIntAtBase) import Data.Char(intToDigit, ord, chr) +import Control.Monad(when, foldM, zipWithM, mapAndUnzipM) +import Control.Monad.Fix(mfix) --import Control.Monad.Fix -import Control.Monad.State +import Control.Monad.State(State, evalState, liftIO, get, put) import Data.Graph import qualified Data.Generics as Generic import System.IO(Handle, BufferMode(..), IOMode(..), stdout, stderr, diff --git a/src/comp/IExpandUtils.hs b/src/comp/IExpandUtils.hs index e4913880f..443a40b8c 100644 --- a/src/comp/IExpandUtils.hs +++ b/src/comp/IExpandUtils.hs @@ -62,7 +62,9 @@ module IExpandUtils( showTopProgress, showModProgress, showRuleProgress ) where -import Control.Monad.State +import Control.Monad(when, liftM) +import Control.Monad.State(StateT, runStateT, evalStateT, lift, liftIO, + gets, get, put, modify) import Data.IORef import System.IO.Unsafe import Data.List diff --git a/src/comp/ITransform.hs b/src/comp/ITransform.hs index 95e2a5c7e..4df3f77ef 100644 --- a/src/comp/ITransform.hs +++ b/src/comp/ITransform.hs @@ -17,8 +17,8 @@ module ITransform( import Prelude hiding ((<>)) #endif -import Data.Traversable (forM) -import Control.Monad.State hiding (forM) +import Control.Monad(foldM, forM) +import Control.Monad.State(State, runState, gets, get, put) import Data.List((\\)) import qualified Data.Map as M diff --git a/src/comp/LambdaCalc.hs b/src/comp/LambdaCalc.hs index 762fbce57..3e305976f 100644 --- a/src/comp/LambdaCalc.hs +++ b/src/comp/LambdaCalc.hs @@ -11,7 +11,8 @@ import Prelude hiding ((<>)) import qualified Data.Map as M import qualified Data.Set as S -import Control.Monad.State +import Control.Monad(foldM) +import Control.Monad.State(State, runState, gets, get, put) import Data.Maybe(mapMaybe) import Data.Char(toLower) diff --git a/src/comp/LambdaCalcUtil.hs b/src/comp/LambdaCalcUtil.hs index 3ff347071..1ed84f5a5 100644 --- a/src/comp/LambdaCalcUtil.hs +++ b/src/comp/LambdaCalcUtil.hs @@ -24,7 +24,8 @@ module LambdaCalcUtil( import qualified Data.Map as M import qualified Data.Set as S -import Control.Monad.State +import Control.Monad(when) +import Control.Monad.State(State, runState, gets, get, put) import Data.Maybe(isJust, catMaybes) import Data.List(intercalate, partition, union, nub) diff --git a/src/comp/Parser/BSV/CVParserCommon.lhs b/src/comp/Parser/BSV/CVParserCommon.lhs index beee98e36..fd70621b7 100644 --- a/src/comp/Parser/BSV/CVParserCommon.lhs +++ b/src/comp/Parser/BSV/CVParserCommon.lhs @@ -7,8 +7,9 @@ #endif -> import Control.Monad.State -> import Control.Monad.Except +> import Control.Monad(when) +> import Control.Monad.State(modify, gets, get, put) +> import Control.Monad.Except(throwError) > import SystemVerilogTokens > import Flags(Flags, passThroughAssertions) diff --git a/src/comp/Parser/Classic/Warnings.hs b/src/comp/Parser/Classic/Warnings.hs index 93edb5bf8..7f68511da 100644 --- a/src/comp/Parser/Classic/Warnings.hs +++ b/src/comp/Parser/Classic/Warnings.hs @@ -1,7 +1,8 @@ module Parser.Classic.Warnings(classicWarnings) where -import Control.Monad.Reader -import Control.Monad.Writer +import Control.Monad(when) +import Control.Monad.Reader(ReaderT, runReaderT, ask, local) +import Control.Monad.Writer(Writer, runWriter, tell, listen, censor) import Data.Maybe import qualified Data.Set as S import qualified Data.Map as M diff --git a/src/comp/Pred2STP.hs b/src/comp/Pred2STP.hs index 815e5e80d..e209080d1 100644 --- a/src/comp/Pred2STP.hs +++ b/src/comp/Pred2STP.hs @@ -4,7 +4,8 @@ module Pred2STP( solvePred ) where -import Control.Monad.State +import Control.Monad(when) +import Control.Monad.State(StateT, liftIO, gets, get, put, runStateT) import qualified Data.Map as M import qualified STP as S diff --git a/src/comp/Pred2Yices.hs b/src/comp/Pred2Yices.hs index 43cce00c1..c24f6e56b 100644 --- a/src/comp/Pred2Yices.hs +++ b/src/comp/Pred2Yices.hs @@ -4,7 +4,8 @@ module Pred2Yices( solvePred ) where -import Control.Monad.State +import Control.Monad(when) +import Control.Monad.State(StateT, liftIO, gets, get, put, runStateT) import qualified Data.Map as M import qualified Yices as Y diff --git a/src/comp/SAL.hs b/src/comp/SAL.hs index a4087e663..f4714dbf4 100644 --- a/src/comp/SAL.hs +++ b/src/comp/SAL.hs @@ -11,7 +11,8 @@ import Prelude hiding ((<>)) import qualified Data.Map as M import qualified Data.Set as S -import Control.Monad.State +import Control.Monad(foldM) +import Control.Monad.State(State, runState, gets, get, put) import Data.Maybe(mapMaybe) import Data.Char(toLower) import Data.List(intersperse, groupBy) diff --git a/src/comp/SimCCBlock.hs b/src/comp/SimCCBlock.hs index 64b9cf821..e019bd090 100644 --- a/src/comp/SimCCBlock.hs +++ b/src/comp/SimCCBlock.hs @@ -69,7 +69,8 @@ import Data.Maybe import Data.List(partition, intersperse, intercalate, nub, sortBy) import Data.List.Split(wordsBy) import Numeric(showHex) -import Control.Monad.State(State, gets, modify, when) +import Control.Monad(when) +import Control.Monad.State(State, gets, modify) import Data.Char(toLower) import qualified Data.Map as Map diff --git a/src/comp/Synthesize.hs b/src/comp/Synthesize.hs index 7c2db3749..510ae729b 100644 --- a/src/comp/Synthesize.hs +++ b/src/comp/Synthesize.hs @@ -1,7 +1,8 @@ module Synthesize(aSynthesize) where import Data.List(transpose, sort, genericLength, nub) -import Control.Monad.State +import Control.Monad(when, zipWithM, zipWithM_) +import Control.Monad.State(State, runState, gets, get, put) import Debug.Trace import qualified Data.Map as M diff --git a/src/comp/TIMonad.hs b/src/comp/TIMonad.hs index c7a2e8b70..2651ee422 100644 --- a/src/comp/TIMonad.hs +++ b/src/comp/TIMonad.hs @@ -44,7 +44,9 @@ import SymTab import PreIds(idBits, idLiteral, idRealLiteral, idSizedLiteral, idStringLiteral, idNumEq) import ErrorTCompat -import Control.Monad.State +import Control.Monad(when) +import Control.Monad.State(State, StateT, runState, runStateT, + lift, gets, get, put, modify) import Data.List(partition) import Util(headOrErr) diff --git a/src/comp/VVerilogDollar.hs b/src/comp/VVerilogDollar.hs index 0fba24a33..4b84b8db0 100644 --- a/src/comp/VVerilogDollar.hs +++ b/src/comp/VVerilogDollar.hs @@ -4,7 +4,8 @@ import FStringCompat import PreStrings (fsDollar) import Verilog import Data.Generics -import Control.Monad.State +import Control.Monad(guard) +import Control.Monad.State(State, gets, put, execState) import qualified Data.Map as Map import qualified Data.Set as Set import ErrorUtil (internalError) diff --git a/src/comp/bluetcl.hs b/src/comp/bluetcl.hs index 3f73f2d9b..c134743ff 100644 --- a/src/comp/bluetcl.hs +++ b/src/comp/bluetcl.hs @@ -13,7 +13,8 @@ module BlueTcl where import HTcl import Control.Monad(foldM, when, mzero) -import ErrorTCompat +import Control.Monad.Trans(lift) +import Control.Monad.Except(ExceptT, runExceptT, throwError) import Control.Concurrent import qualified Control.Exception as CE import System.IO.Error(ioeGetErrorString) From c73048abcc7a823d5659e157570b8a2f8dea7477 Mon Sep 17 00:00:00 2001 From: Julie Schwartz Date: Fri, 4 Aug 2023 21:41:41 +1200 Subject: [PATCH 4/4] Remove unnecessary ErrorTCompat This abstraction was added to support building with GHC 7.10 (which uses Control.Monad.Except) and older versions (which still used Control.Monad.Error), without having to introduce CPP directives everywhere. Since we no longer support those earlier GHC versions, there is no need for this API. --- src/comp/ABinUtil.hs | 18 +++++++++--------- src/comp/AConv.hs | 2 +- src/comp/ASchedule.hs | 6 +++--- src/comp/Error.hs | 14 +++++++------- src/comp/ErrorMonad.hs | 2 +- src/comp/ErrorTCompat.hs | 12 ------------ src/comp/GenWrap.hs | 8 ++++---- src/comp/IInlineFmt.hs | 6 +++--- src/comp/MakeSymTab.hs | 2 +- src/comp/SimExpand.hs | 6 +++--- src/comp/TIMonad.hs | 6 +++--- src/comp/bluetcl.hs | 16 ++++++++-------- src/comp/bsc.hs | 6 +++--- src/comp/showrules.hs | 6 +++--- 14 files changed, 49 insertions(+), 61 deletions(-) delete mode 100644 src/comp/ErrorTCompat.hs diff --git a/src/comp/ABinUtil.hs b/src/comp/ABinUtil.hs index cd0bccf63..503a9cd5d 100644 --- a/src/comp/ABinUtil.hs +++ b/src/comp/ABinUtil.hs @@ -9,8 +9,8 @@ module ABinUtil ( import Data.List(nub, partition) import Data.Maybe(isJust, fromJust) import Control.Monad(when) +import Control.Monad.Except(ExceptT, throwError) import Control.Monad.State(StateT, runStateT, lift, get, put) -import ErrorTCompat import Version(bscVersionStr) import Backend @@ -19,7 +19,7 @@ import FileIOUtil(readBinaryFileCatch, readBinFilePath) import Util(fromMaybeM) import Error(internalError, EMsg, EMsgs(..), ErrMsg(..), - ErrorHandle, bsError, bsWarning, convErrorTToIO) + ErrorHandle, bsError, bsWarning, convExceptTToIO) import Id(Id, getIdString) import Position(cmdPosition, noPosition, getPosition) import PPrint @@ -63,11 +63,11 @@ type ABinMap = M.Map String FilePath -- -- When linking Verilog, we want to try reading in a .ba hierarchy, -- but fall back to using .v files if it fails. --- Therefore, ErrorT is used to catch errors. Serious failures can +-- Therefore, ExceptT is used to catch errors. Serious failures can -- still be reported immediately, via IO -- such as file version mismatch, -- or read errors, etc. -- -type M = StateT MState (ErrorT EMsgs IO) +type M = StateT MState (ExceptT EMsgs IO) -- monad state data MState = MState { @@ -126,7 +126,7 @@ putHierMap m = get >>= \s -> put (s { m_foundmod_map = m }) getABIHierarchy :: ErrorHandle -> Bool -> [String] -> (Maybe Backend) -> [String] -> String -> [(String, ABin)] -> - ErrorT EMsgs IO + ExceptT EMsgs IO (Id, HierMap, InstModMap, ForeignFuncMap, ABinMap, [String], [(String, (ABinEitherModInfo, String))]) getABIHierarchy errh be_verbose ifc_path backend prim_names topname fabis = do @@ -202,11 +202,11 @@ getABIHierarchy errh be_verbose ifc_path backend prim_names topname fabis = do -- back the abmis with just the success data types assertNoSchedErr :: [(String, (ABinEitherModInfo, String))] -> - ErrorT EMsgs IO + ExceptT EMsgs IO [(String, (ABinModInfo, String))] assertNoSchedErr modinfos_by_name = let assertOne :: (String, (ABinEitherModInfo, String)) -> - ErrorT EMsgs IO + ExceptT EMsgs IO (String, (ABinModInfo, String)) assertOne (name, (eabmi, ver)) = case eabmi of @@ -472,7 +472,7 @@ readAndCheckABin errh backend filename = do -- returns the filename and the contents readAndCheckABinPath :: ErrorHandle -> Bool -> [String] -> (Maybe Backend) -> String -> - (ErrorT EMsgs IO) (Maybe (String, ABin)) + (ExceptT EMsgs IO) (Maybe (String, ABin)) readAndCheckABinPath errh be_verbose path backend mod_name = do let binname = mod_name ++ "." ++ abinSuffix mread <- lift $ readBinFilePath errh noPosition be_verbose binname path @@ -494,7 +494,7 @@ readAndCheckABinPathCatch :: ErrorHandle -> Bool -> [String] -> (Maybe Backend) -> String -> EMsg -> IO (String, ABin) readAndCheckABinPathCatch errh be_verbose path backend mod_name errmsg = do - mabi <- convErrorTToIO errh $ + mabi <- convExceptTToIO errh $ readAndCheckABinPath errh be_verbose path backend mod_name case mabi of Nothing -> bsError errh [errmsg] diff --git a/src/comp/AConv.hs b/src/comp/AConv.hs index ef2982da5..2ea42a585 100644 --- a/src/comp/AConv.hs +++ b/src/comp/AConv.hs @@ -2,8 +2,8 @@ module AConv (aConv, aTypeConv, isLocalAId) where import Util(itos, headOrErr, initOrErr, lastOrErr, log2, concatMapM, makePairs) import qualified Data.Map as M -import ErrorTCompat import Control.Monad(when, liftM, forM, zipWithM) +import Control.Monad.Except(throwError) import Control.Monad.State(StateT, runStateT, gets, get, put) import Control.Monad.Reader(ReaderT, runReaderT, withReaderT, ask) import PPrint(ppReadable, ppString) diff --git a/src/comp/ASchedule.hs b/src/comp/ASchedule.hs index b44191390..71607f32f 100644 --- a/src/comp/ASchedule.hs +++ b/src/comp/ASchedule.hs @@ -19,8 +19,8 @@ import Prelude hiding ((<>)) import Data.List import Data.Maybe -import ErrorTCompat import Control.Monad(when, foldM) +import Control.Monad.Except(ExceptT, runExceptT, throwError) import Control.Monad.State(StateT, runStateT, lift, get, put) import System.IO.Unsafe import Debug.Trace(traceM) @@ -355,7 +355,7 @@ csGraphToSchedGraph edges = -- In order to record the warnings during scheduling, we operate on a -- state monad which stores the EMsgs. -type SM = ErrorT EMsgs (StateT SState IO) +type SM = ExceptT EMsgs (StateT SState IO) data SState = SState { sm_warnings :: [EMsg], @@ -426,7 +426,7 @@ aSchedule :: ErrorHandle -> Flags -> IO (Either AScheduleErrInfo (AScheduleInfo, APackage)) aSchedule errh flags prefix urgency_pairs pps amod = do let f = aSchedule' errh flags prefix urgency_pairs pps amod - (result, s) <- runStateT (runErrorT f) initSState + (result, s) <- runStateT (runExceptT f) initSState let processWarning e@(pos,msg) = (pos, getErrMsgTag msg, showWarningList [e]) diff --git a/src/comp/Error.hs b/src/comp/Error.hs index 048a11cfc..6c209742c 100644 --- a/src/comp/Error.hs +++ b/src/comp/Error.hs @@ -39,8 +39,8 @@ module Error( -- exit with the same code as a system call that failed exitFailWith, - -- report errors in ErrorT [EMsg] IO - convErrorTToIO, + -- report errors in ExceptT [EMsg] IO + convExceptTToIO, -- used for displaying messages as a string -- (in .ba file, in Verilog dynamic error, in Tcl) @@ -70,8 +70,8 @@ import Data.List(genericLength) import qualified Data.Set as S import System.IO(Handle, hClose, hPutStr, stderr) import System.Exit(exitWith, ExitCode(..)) -import ErrorTCompat import Control.Monad(when) +import Control.Monad.Except(ExceptT, runExceptT) import qualified Control.Exception as CE import Data.IORef import System.IO.Unsafe(unsafePerformIO) @@ -413,15 +413,15 @@ exitOK ref = do -- ------------------------- --- We can't use [EMsg] with ErrorT because it leads to overlapping +-- We can't use [EMsg] with ExceptT because it leads to overlapping -- instance problems. Instead, we will wrap it with a newtype. newtype EMsgs = EMsgs { errmsgs :: [EMsg] } -- ------------------------- -convErrorTToIO :: ErrorHandle -> ErrorT EMsgs IO a -> IO a -convErrorTToIO ref fn = - do mres <- runErrorT fn +convExceptTToIO :: ErrorHandle -> ExceptT EMsgs IO a -> IO a +convExceptTToIO ref fn = + do mres <- runExceptT fn case mres of Left msgs -> bsError ref (errmsgs msgs) Right res -> return res diff --git a/src/comp/ErrorMonad.hs b/src/comp/ErrorMonad.hs index 2e8dde519..067258384 100644 --- a/src/comp/ErrorMonad.hs +++ b/src/comp/ErrorMonad.hs @@ -2,8 +2,8 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} module ErrorMonad(ErrorMonad(..), convErrorMonadToIO) where -import ErrorTCompat import Control.Monad(ap) +import Control.Monad.Except(MonadError, throwError, catchError) #if !defined(__GLASGOW_HASKELL__) || ((__GLASGOW_HASKELL__ >= 800) && (__GLASGOW_HASKELL__ < 808)) import Control.Monad.Fail(MonadFail(..)) #endif diff --git a/src/comp/ErrorTCompat.hs b/src/comp/ErrorTCompat.hs deleted file mode 100644 index b5f7d3811..000000000 --- a/src/comp/ErrorTCompat.hs +++ /dev/null @@ -1,12 +0,0 @@ -module ErrorTCompat ( - ErrorT, - runErrorT, - MonadError(..) -) where - -import Control.Monad.Except - -type ErrorT = ExceptT - -runErrorT :: ErrorT e m a -> m (Either e a) -runErrorT = runExceptT diff --git a/src/comp/GenWrap.hs b/src/comp/GenWrap.hs index 93f4066dd..f2b61dc1e 100644 --- a/src/comp/GenWrap.hs +++ b/src/comp/GenWrap.hs @@ -10,8 +10,8 @@ import Prelude hiding ((<>)) #endif import Data.List(nub, (\\), find) -import ErrorTCompat import Control.Monad(when, foldM, filterM, zipWithM, mapAndUnzipM) +import Control.Monad.Except(ExceptT, runExceptT, throwError) import Control.Monad.State(StateT, runStateT, lift, gets, get, put) import PFPrint import Position(Position, noPosition, getPositionLine, cmdPosition) @@ -50,7 +50,7 @@ import GenWrapUtils -- ==================== -type GWMonad = StateT GenState (ErrorT EMsgs IO) +type GWMonad = StateT GenState (ExceptT EMsgs IO) data GenState = GenState { @@ -62,7 +62,7 @@ data GenState = GenState runGWMonad :: GWMonad a -> GenState -> IO a runGWMonad f s = do let errh = errHandle s - result <- runErrorT ((runStateT f) s) + result <- runExceptT ((runStateT f) s) case result of Right (res, _) -> return res Left msgs -> bsError errh (errmsgs msgs) @@ -77,7 +77,7 @@ runGWMonadNoFail f s = -- and we don't expect it to fail runGWMonadGetNoFail :: GWMonad a -> GenState -> IO (GenState, a) runGWMonadGetNoFail f s = - do result <- runErrorT ((runStateT f) s) + do result <- runExceptT ((runStateT f) s) case result of Right (res, s2) -> return (s2, res) Left msgs -> internalError ("runGWMonadGetNoFail: " ++ diff --git a/src/comp/IInlineFmt.hs b/src/comp/IInlineFmt.hs index c1b860fca..54c117277 100644 --- a/src/comp/IInlineFmt.hs +++ b/src/comp/IInlineFmt.hs @@ -8,7 +8,7 @@ import Id import Prim import PreIds(idActionValue_, idArrow, tmpVarIds, idAVValue_, idAVAction_, idPrimFmtConcat) import ForeignFunctions -import ErrorTCompat +import Control.Monad.Except(ExceptT, runExceptT) import Control.Monad.State import Error(EMsg, ErrorHandle, bsError) import Position(noPosition) @@ -16,7 +16,7 @@ import CType(TISort(..), StructSubType(..)) import qualified Data.Map as M -- import Debug.Trace(trace) -type F a = StateT (Int, [IDef a]) (ErrorT EMsg (IO)) +type F a = StateT (Int, [IDef a]) (ExceptT EMsg (IO)) newFFCallNo :: (F a) Integer newFFCallNo = do (n, ds) <- get @@ -37,7 +37,7 @@ iInlineFmt errh imod = do let imod_fmt = iInlineFmts imod let ffcallNo = (imod_ffcallNo imod_fmt) let ds = (imod_local_defs imod_fmt) - result <- runErrorT (runStateT (splitFmtsF imod_fmt) (ffcallNo, [])) + result <- runExceptT (runStateT (splitFmtsF imod_fmt) (ffcallNo, [])) case result of Right x@(imod', (ffcallNo', ds')) -> return (imod' {imod_local_defs = ds ++ ds', diff --git a/src/comp/MakeSymTab.hs b/src/comp/MakeSymTab.hs index 793604298..ffbc1043f 100644 --- a/src/comp/MakeSymTab.hs +++ b/src/comp/MakeSymTab.hs @@ -12,8 +12,8 @@ import Prelude hiding ((<>)) #endif import Data.List -import ErrorTCompat import Control.Monad(when) +import Control.Monad.Except(throwError) import qualified Data.Set as S import qualified Data.Map as M diff --git a/src/comp/SimExpand.hs b/src/comp/SimExpand.hs index 027996c22..bbacf1bad 100644 --- a/src/comp/SimExpand.hs +++ b/src/comp/SimExpand.hs @@ -10,7 +10,7 @@ import qualified Data.Set as S import IOUtil(progArgs) import Error (internalError, EMsg, ErrMsg(..), ErrorHandle, bsError, - convErrorTToIO) + convExceptTToIO) import Position (noPosition, getPosition) import PPrint import Flags @@ -66,11 +66,11 @@ simExpand errh flags topname fabis = do let prim_names = map sb_name primBlocks (topmodId, hiermap, instmap, ffuncmap, filemap, _, emodinfos_used_by_name) - <- convErrorTToIO errh $ + <- convExceptTToIO errh $ getABIHierarchy errh (verbose flags) (ifcPath flags) (Just Bluesim) prim_names topname fabis - modinfos_used_by_name <- convErrorTToIO errh $ + modinfos_used_by_name <- convExceptTToIO errh $ assertNoSchedErr emodinfos_used_by_name -- reject top-level modules with always_enabled ifc, if generating diff --git a/src/comp/TIMonad.hs b/src/comp/TIMonad.hs index 2651ee422..82a65564a 100644 --- a/src/comp/TIMonad.hs +++ b/src/comp/TIMonad.hs @@ -43,8 +43,8 @@ import Assump import SymTab import PreIds(idBits, idLiteral, idRealLiteral, idSizedLiteral, idStringLiteral, idNumEq) -import ErrorTCompat import Control.Monad(when) +import Control.Monad.Except(ExceptT, runExceptT, throwError, catchError) import Control.Monad.State(State, StateT, runState, runStateT, lift, gets, get, put, modify) import Data.List(partition) @@ -128,7 +128,7 @@ sizedStackModify (SizedStack size (x:rest)) f = sizedStackModify _ _ = internalError "sizedStackModify: stack underflow" -- state/error monad with bsc error messages and hidden TState -type TI = StateT TStateRecover (ErrorT EMsgs (State TStatePersistent)) +type TI = StateT TStateRecover (ExceptT EMsgs (State TStatePersistent)) -- apply the current substitution to something apSubTI :: (Types a) => a -> TI a @@ -158,7 +158,7 @@ runTI :: Flags -> Bool -> SymTab -> TI a -> (Either [EMsg] a, [WMsg]) runTI flags ai s m = (final_result, tsWarns pState) where (result, pState) = runState error_run (initPersistentState flags ai s) - error_run = (runErrorT (runStateT m initRecoverState)) + error_run = (runExceptT (runStateT m initRecoverState)) rec_errors = tsRecoveredErrors pState final_result = case result of diff --git a/src/comp/bluetcl.hs b/src/comp/bluetcl.hs index c134743ff..abb46eb99 100644 --- a/src/comp/bluetcl.hs +++ b/src/comp/bluetcl.hs @@ -47,7 +47,7 @@ import Flags(Flags(..), verbose) import FlagsDecode(defaultFlags, decodeFlags, adjustFinalFlags, updateFlags, showFlagsLst, showFlagsAllLst, getFlagValueString) import Error(internalError, EMsg, ErrMsg(..), showErrorList, - ErrorHandle, initErrorHandle, convErrorTToIO) + ErrorHandle, initErrorHandle, convExceptTToIO) import Id import PPrint import PVPrint @@ -975,7 +975,7 @@ tclModule ["load",topname] = do ": it is a primitive module") -- getABIHierarchy calls GenABin.readABinFile to read a .ba file (topmodId, hierMap, instModMap, ffuncMap, _, foreign_mods, abmis_by_name) - <- convErrorTToIO globalErrHandle $ + <- convExceptTToIO globalErrHandle $ getABIHierarchy globalErrHandle (verbose flags) (ifcPath flags) (Just gen_backend) prim_names topname [] @@ -3285,13 +3285,13 @@ data IfcField = getIfcHierarchy :: Maybe Id -> [(Id, RawIfcField)] -> Type -> IO [IfcField] getIfcHierarchy instId raw_fields tifc = do - mres <- runErrorT (mgetIfcHierarchy instId raw_fields tifc) + mres <- runExceptT (mgetIfcHierarchy instId raw_fields tifc) case mres of Right res -> return res Left msg -> internalError msg mgetIfcHierarchy :: Maybe Id -> [(Id, RawIfcField)] -> Type -> - ErrorT String IO [IfcField] + ExceptT String IO [IfcField] mgetIfcHierarchy instId raw_fields tifc = do -- use "expandSyn" to avoid getting back "Alias" as the type analysis maifc <- lift $ getTypeAnalysis' (expandSyn tifc) True @@ -3301,7 +3301,7 @@ mgetIfcHierarchy instId raw_fields tifc = do ifc_map = M.fromList raw_fields -- get the AIF for a flattened name - lookupAIF :: Id -> ErrorT String IO RawIfcField + lookupAIF :: Id -> ExceptT String IO RawIfcField lookupAIF i = case (M.lookup i ifc_map) of Just aif -> return aif @@ -3322,10 +3322,10 @@ mgetIfcHierarchy instId raw_fields tifc = do -- get the IfcField for one field getField :: Id -> (Bool, Id, Qual Type, [IfcPragma]) -> - ErrorT String IO IfcField + ExceptT String IO IfcField getField prefix (_, fId, (_ :=> t), _) = getField' prefix fId t - getField' :: Id -> Id -> Type -> ErrorT String IO IfcField + getField' :: Id -> Id -> Type -> ExceptT String IO IfcField getField' prefix fId t = do -- Function for expanding Vectors of subinterfaces -- (or pseudo-interfaces like Clock, Reset, Inout) @@ -3530,7 +3530,7 @@ getSubmodPortInfo mtifc avi = do let defl_ifc_hier = [ (Field fId inf Nothing) | (fId, inf) <- ifc_map ] in case mtifc of Just tifc -> do - mres <- runErrorT $ + mres <- runExceptT $ mgetIfcHierarchy (Just (avi_vname avi)) ifc_map tifc case mres of Right res -> return res diff --git a/src/comp/bsc.hs b/src/comp/bsc.hs index 776d65165..43db1e035 100644 --- a/src/comp/bsc.hs +++ b/src/comp/bsc.hs @@ -20,7 +20,7 @@ import Data.Maybe(isJust, isNothing {-, fromMaybe-}) import Numeric(showOct) import Control.Monad(when, unless, filterM, liftM, foldM) -import ErrorTCompat(runErrorT) +import Control.Monad.Except(runExceptT) import Control.Concurrent(forkIO) import Control.Concurrent.MVar(newEmptyMVar, putMVar, takeMVar) import qualified Control.Exception as CE @@ -1873,7 +1873,7 @@ vLink errh flags topmod_name vfilenames0 afilenames cfilenames = do -- see if .ba files exist for the top-level of this design let prim_names = map sb_name primBlocks - mhier0 <- runErrorT $ + mhier0 <- runExceptT $ getABIHierarchy errh (verbose flags) (ifcPath flags) (Just Verilog) prim_names topmod_name user_abis @@ -1881,7 +1881,7 @@ vLink errh flags topmod_name vfilenames0 afilenames cfilenames = do mhier <- case mhier0 of Left msgs -> return (Left msgs) Right (a, b, c, d, e, f, emodinfos) -> do - mres <- runErrorT (assertNoSchedErr emodinfos) + mres <- runExceptT (assertNoSchedErr emodinfos) case mres of Left msgs -> return (Left msgs) Right modinfos -> return $ diff --git a/src/comp/showrules.hs b/src/comp/showrules.hs index 792662efe..868857728 100644 --- a/src/comp/showrules.hs +++ b/src/comp/showrules.hs @@ -13,7 +13,7 @@ import Id( Id, getIdString, getIdBaseString, getIdQualString import Error(internalError, EMsg, WMsg, ErrMsg(..), ErrorHandle, initErrorHandle, exitOK, exitFail, bsErrorNoExit, bsWarning, - convErrorTToIO) + convExceptTToIO) import Util(separate, headOrErr, fromJustOrErr, unconsOrErr) import IOUtil(getEnvDef) import TopUtils(dfltBluespecDir) @@ -300,9 +300,9 @@ hmain argv = do let prim_names = map sb_name primBlocks when (verbose) $ putStrLn "Reading design data from .ba files..." (_, hier_map, inst_map, _, _, _, abemis_by_name) - <- convErrorTToIO errh $ + <- convExceptTToIO errh $ getABIHierarchy errh verbose ba_path Nothing prim_names top_mod [] - abmis_by_name <- convErrorTToIO errh $ assertNoSchedErr abemis_by_name + abmis_by_name <- convExceptTToIO errh $ assertNoSchedErr abemis_by_name -- analyze design in preparation for VCD interpretation when (verbose) $ putStrLn "Analyzing design structure..."