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/ABinUtil.hs b/src/comp/ABinUtil.hs index a9f055d8d..503a9cd5d 100644 --- a/src/comp/ABinUtil.hs +++ b/src/comp/ABinUtil.hs @@ -8,8 +8,9 @@ module ABinUtil ( import Data.List(nub, partition) import Data.Maybe(isJust, fromJust) -import Control.Monad.State -import ErrorTCompat +import Control.Monad(when) +import Control.Monad.Except(ExceptT, throwError) +import Control.Monad.State(StateT, runStateT, lift, get, put) import Version(bscVersionStr) import Backend @@ -18,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 @@ -62,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 { @@ -125,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 @@ -201,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 @@ -471,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 @@ -493,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/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/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 8b6aa158f..2ea42a585 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.Except(throwError) +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 @@ -519,7 +518,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 +533,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 +965,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/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 6f0da24a7..e6fe65589 100644 --- a/src/comp/AOpt.hs +++ b/src/comp/AOpt.hs @@ -11,14 +11,16 @@ 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 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 +1005,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 +1594,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 +1604,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/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 f36917192..71607f32f 100644 --- a/src/comp/ASchedule.hs +++ b/src/comp/ASchedule.hs @@ -19,8 +19,9 @@ import Prelude hiding ((<>)) import Data.List import Data.Maybe -import ErrorTCompat -import Control.Monad.State +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) import qualified Data.Map as M @@ -43,7 +44,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) @@ -354,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], @@ -425,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]) @@ -3141,8 +3142,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 +4276,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 +4416,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 +4523,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 +5196,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/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 a9e29fed0..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) @@ -175,7 +176,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/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 9c7fc619a..000000000 --- a/src/comp/ErrorTCompat.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE CPP #-} -module ErrorTCompat ( - ErrorT, - runErrorT, - MonadError(..), - lift -) 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 6ed270b66..f2b61dc1e 100644 --- a/src/comp/GenWrap.hs +++ b/src/comp/GenWrap.hs @@ -10,8 +10,9 @@ import Prelude hiding ((<>)) #endif import Data.List(nub, (\\), find) -import ErrorTCompat -import Control.Monad.State +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) import Error(internalError, EMsg, EMsgs(..), ErrMsg(..), ErrorHandle, bsError) @@ -49,7 +50,7 @@ import GenWrapUtils -- ==================== -type GWMonad = StateT GenState (ErrorT EMsgs IO) +type GWMonad = StateT GenState (ExceptT EMsgs IO) data GenState = GenState { @@ -61,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) @@ -76,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: " ++ @@ -636,7 +637,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 +889,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 +989,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 +1358,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 +1369,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 +1497,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 +1764,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 +2167,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..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, @@ -1074,7 +1076,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 +3109,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 +3124,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 +4298,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/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/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/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..4df3f77ef 100644 --- a/src/comp/ITransform.hs +++ b/src/comp/ITransform.hs @@ -17,14 +17,14 @@ 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 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/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/MakeSymTab.hs b/src/comp/MakeSymTab.hs index 2546a08de..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 @@ -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..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) @@ -33,7 +34,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 +1278,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 +1333,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/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/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/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 1d9252d86..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) @@ -369,8 +370,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..e019bd090 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) @@ -68,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 @@ -386,7 +388,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 +404,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 +417,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 +439,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 +470,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..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 @@ -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..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 @@ -159,14 +160,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/TIMonad.hs b/src/comp/TIMonad.hs index c7a2e8b70..82a65564a 100644 --- a/src/comp/TIMonad.hs +++ b/src/comp/TIMonad.hs @@ -43,8 +43,10 @@ import Assump import SymTab import PreIds(idBits, idLiteral, idRealLiteral, idSizedLiteral, idStringLiteral, idNumEq) -import ErrorTCompat -import Control.Monad.State +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) import Util(headOrErr) @@ -126,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 @@ -156,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/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/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 4703a047d..abb46eb99 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) @@ -46,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 @@ -974,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 [] @@ -2086,7 +2087,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) @@ -3283,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 @@ -3299,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 @@ -3320,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) @@ -3528,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 9bde48246..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 $ @@ -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..868857728 100644 --- a/src/comp/showrules.hs +++ b/src/comp/showrules.hs @@ -13,8 +13,8 @@ import Id( Id, getIdString, getIdBaseString, getIdQualString import Error(internalError, EMsg, WMsg, ErrMsg(..), ErrorHandle, initErrorHandle, exitOK, exitFail, bsErrorNoExit, bsWarning, - convErrorTToIO) -import Util(separate) + convExceptTToIO) +import Util(separate, headOrErr, fromJustOrErr, unconsOrErr) import IOUtil(getEnvDef) import TopUtils(dfltBluespecDir) import ASyntax @@ -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..." @@ -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/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