diff options
| author | Hécate <hecate+gitlab@glitchbra.in> | 2020-10-10 21:15:36 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-11-01 01:11:09 -0400 |
| commit | dfd27445308d1ed2df8826c2a045130e918e8192 (patch) | |
| tree | 99fc01edeebc2924ddb7533864e0d4ca18cfe800 | |
| parent | bd4abdc953427e084e7ecba89db64860f6859822 (diff) | |
| download | haskell-dfd27445308d1ed2df8826c2a045130e918e8192.tar.gz | |
Add the proper HLint rules and remove redundant keywords from compiler
113 files changed, 1232 insertions, 1314 deletions
diff --git a/compiler/.hlint.yaml b/compiler/.hlint.yaml index 6ebe02e94c..16e593d87c 100644 --- a/compiler/.hlint.yaml +++ b/compiler/.hlint.yaml @@ -5,3 +5,20 @@ - ignore: {} - warn: {name: Unused LANGUAGE pragma} - warn: {name: Use fewer LANGUAGE pragmas} +- warn: {name: Redundant return} +- warn: {name: Redundant True guards} +- warn: {name: Redundant do} +- warn: {name: Redundant variable capture} +- warn: {name: Redundant void} +- warn: {name: Redundant as} +- warn: {name: Use fewer imports} +- warn: {name: Redundant as-pattern} +- warn: {name: Redundant where} + +## Exceptions +# Sometimes, the hlint parser flags some functions and modules as incorrectly +# using a language extension. Some other times, we need to make exceptions to +# lints that we otherwise want applied elsewhere. Such exceptions are listed +# below. + +- ignore: {name: Redundant do, within: [GHC.SysTools.Terminal, GHC.Utils.Binary]} diff --git a/compiler/GHC/Cmm/Graph.hs b/compiler/GHC/Cmm/Graph.hs index be7eafb162..edff1d8f11 100644 --- a/compiler/GHC/Cmm/Graph.hs +++ b/compiler/GHC/Cmm/Graph.hs @@ -250,10 +250,10 @@ mkCallReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr] -> UpdFrameOffset -> [CmmExpr] -> CmmAGraph -mkCallReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off extra_stack = do +mkCallReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off extra_stack = lastWithArgsAndExtraStack profile Call (Young ret_lbl) callConv actuals - updfr_off extra_stack $ - toCall f (Just ret_lbl) updfr_off ret_off + updfr_off extra_stack $ + toCall f (Just ret_lbl) updfr_off ret_off -- Like mkCallReturnsTo, but does not push the return address (it is assumed to be -- already on the stack). @@ -262,9 +262,9 @@ mkJumpReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr] -> ByteOff -> UpdFrameOffset -> CmmAGraph -mkJumpReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off = do +mkJumpReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off = lastWithArgs profile JumpRet (Young ret_lbl) callConv actuals updfr_off $ - toCall f (Just ret_lbl) updfr_off ret_off + toCall f (Just ret_lbl) updfr_off ret_off mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as diff --git a/compiler/GHC/Cmm/LayoutStack.hs b/compiler/GHC/Cmm/LayoutStack.hs index 5b393de902..9e86ab58c5 100644 --- a/compiler/GHC/Cmm/LayoutStack.hs +++ b/compiler/GHC/Cmm/LayoutStack.hs @@ -451,26 +451,25 @@ handleLastNode handleLastNode dflags procpoints liveness cont_info stackmaps stack0@StackMap { sm_sp = sp0 } tscp middle last - = case last of - -- At each return / tail call, - -- adjust Sp to point to the last argument pushed, which - -- is cml_args, after popping any other junk from the stack. - CmmCall{ cml_cont = Nothing, .. } -> do - let sp_off = sp0 - cml_args - return ([], sp_off, last, [], mapEmpty) - - -- At each CmmCall with a continuation: - CmmCall{ cml_cont = Just cont_lbl, .. } -> - return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off - - CmmForeignCall{ succ = cont_lbl, .. } -> do - return $ lastCall cont_lbl (platformWordSizeInBytes platform) ret_args ret_off - -- one word of args: the return address - - CmmBranch {} -> handleBranches - CmmCondBranch {} -> handleBranches - CmmSwitch {} -> handleBranches - + = case last of + -- At each return / tail call, + -- adjust Sp to point to the last argument pushed, which + -- is cml_args, after popping any other junk from the stack. + CmmCall{ cml_cont = Nothing, .. } -> do + let sp_off = sp0 - cml_args + return ([], sp_off, last, [], mapEmpty) + + -- At each CmmCall with a continuation: + CmmCall{ cml_cont = Just cont_lbl, .. } -> + return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off + + CmmForeignCall{ succ = cont_lbl, .. } -> + return $ lastCall cont_lbl (platformWordSizeInBytes platform) ret_args ret_off + -- one word of args: the return address + + CmmBranch {} -> handleBranches + CmmCondBranch {} -> handleBranches + CmmSwitch {} -> handleBranches where platform = targetPlatform dflags -- Calls and ForeignCalls are handled the same way: @@ -1051,7 +1050,7 @@ insertReloadsAsNeeded -> BlockId -> [CmmBlock] -> UniqSM [CmmBlock] -insertReloadsAsNeeded platform procpoints final_stackmaps entry blocks = do +insertReloadsAsNeeded platform procpoints final_stackmaps entry blocks = toBlockList . fst <$> rewriteCmmBwd liveLattice rewriteCC (ofBlockList entry blocks) mapEmpty where diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs index d408402e27..59dc19ba80 100644 --- a/compiler/GHC/Cmm/Pipeline.hs +++ b/compiler/GHC/Cmm/Pipeline.hs @@ -62,95 +62,95 @@ cpsTop :: DynFlags -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl cpsTop dflags p@(CmmData _ statics) = return (Right (cafAnalData (targetPlatform dflags) statics, p)) cpsTop dflags proc = do - ----------- Control-flow optimisations ---------------------------------- - - -- The first round of control-flow optimisation speeds up the - -- later passes by removing lots of empty blocks, so we do it - -- even when optimisation isn't turned on. - -- - CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-} - return $ cmmCfgOptsProc splitting_proc_points proc - dump Opt_D_dump_cmm_cfg "Post control-flow optimisations" g - - let !TopInfo {stack_info=StackInfo { arg_space = entry_off - , do_layout = do_layout }} = h - - ----------- Eliminate common blocks ------------------------------------- - g <- {-# SCC "elimCommonBlocks" #-} - condPass Opt_CmmElimCommonBlocks elimCommonBlocks g - Opt_D_dump_cmm_cbe "Post common block elimination" - - -- Any work storing block Labels must be performed _after_ - -- elimCommonBlocks - - ----------- Implement switches ------------------------------------------ - g <- {-# SCC "createSwitchPlans" #-} - runUniqSM $ cmmImplementSwitchPlans (backend dflags) platform g - dump Opt_D_dump_cmm_switch "Post switch plan" g - - ----------- Proc points ------------------------------------------------- - let - call_pps :: ProcPointSet -- LabelMap - call_pps = {-# SCC "callProcPoints" #-} callProcPoints g - proc_points <- - if splitting_proc_points - then do - pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $ - minimalProcPointSet platform call_pps g - dumpWith dflags Opt_D_dump_cmm_proc "Proc points" - FormatCMM (pdoc platform l $$ ppr pp $$ pdoc platform g) - return pp - else - return call_pps - - ----------- Layout the stack and manifest Sp ---------------------------- - (g, stackmaps) <- - {-# SCC "layoutStack" #-} - if do_layout - then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g - else return (g, mapEmpty) - dump Opt_D_dump_cmm_sp "Layout Stack" g - - ----------- Sink and inline assignments -------------------------------- - g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout] - condPass Opt_CmmSink (cmmSink platform) g - Opt_D_dump_cmm_sink "Sink assignments" - - ------------- CAF analysis ---------------------------------------------- - let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g - dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv) - - g <- if splitting_proc_points + ----------- Control-flow optimisations ---------------------------------- + + -- The first round of control-flow optimisation speeds up the + -- later passes by removing lots of empty blocks, so we do it + -- even when optimisation isn't turned on. + -- + CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-} + return $ cmmCfgOptsProc splitting_proc_points proc + dump Opt_D_dump_cmm_cfg "Post control-flow optimisations" g + + let !TopInfo {stack_info=StackInfo { arg_space = entry_off + , do_layout = do_layout }} = h + + ----------- Eliminate common blocks ------------------------------------- + g <- {-# SCC "elimCommonBlocks" #-} + condPass Opt_CmmElimCommonBlocks elimCommonBlocks g + Opt_D_dump_cmm_cbe "Post common block elimination" + + -- Any work storing block Labels must be performed _after_ + -- elimCommonBlocks + + ----------- Implement switches ------------------------------------------ + g <- {-# SCC "createSwitchPlans" #-} + runUniqSM $ cmmImplementSwitchPlans (backend dflags) platform g + dump Opt_D_dump_cmm_switch "Post switch plan" g + + ----------- Proc points ------------------------------------------------- + let + call_pps :: ProcPointSet -- LabelMap + call_pps = {-# SCC "callProcPoints" #-} callProcPoints g + proc_points <- + if splitting_proc_points then do - ------------- Split into separate procedures ----------------------- - let pp_map = {-# SCC "procPointAnalysis" #-} - procPointAnalysis proc_points g - dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" - FormatCMM (ppr pp_map) - g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $ - splitAtProcPoints platform l call_pps proc_points pp_map - (CmmProc h l v g) - dumps Opt_D_dump_cmm_split "Post splitting" g - return g - else do - -- attach info tables to return points - return $ [attachContInfoTables call_pps (CmmProc h l v g)] - - ------------- Populate info tables with stack info ----------------- - g <- {-# SCC "setInfoTableStackMap" #-} - return $ map (setInfoTableStackMap platform stackmaps) g - dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g - - ----------- Control-flow optimisations ----------------------------- - g <- {-# SCC "cmmCfgOpts(2)" #-} - return $ if optLevel dflags >= 1 - then map (cmmCfgOptsProc splitting_proc_points) g - else g - g <- return (map removeUnreachableBlocksProc g) - -- See Note [unreachable blocks] - dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g - - return (Left (cafEnv, g)) + pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $ + minimalProcPointSet platform call_pps g + dumpWith dflags Opt_D_dump_cmm_proc "Proc points" + FormatCMM (pdoc platform l $$ ppr pp $$ pdoc platform g) + return pp + else + return call_pps + + ----------- Layout the stack and manifest Sp ---------------------------- + (g, stackmaps) <- + {-# SCC "layoutStack" #-} + if do_layout + then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g + else return (g, mapEmpty) + dump Opt_D_dump_cmm_sp "Layout Stack" g + + ----------- Sink and inline assignments -------------------------------- + g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout] + condPass Opt_CmmSink (cmmSink platform) g + Opt_D_dump_cmm_sink "Sink assignments" + + ------------- CAF analysis ---------------------------------------------- + let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g + dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv) + + g <- if splitting_proc_points + then do + ------------- Split into separate procedures ----------------------- + let pp_map = {-# SCC "procPointAnalysis" #-} + procPointAnalysis proc_points g + dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" + FormatCMM (ppr pp_map) + g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $ + splitAtProcPoints platform l call_pps proc_points pp_map + (CmmProc h l v g) + dumps Opt_D_dump_cmm_split "Post splitting" g + return g + else + -- attach info tables to return points + return $ [attachContInfoTables call_pps (CmmProc h l v g)] + + ------------- Populate info tables with stack info ----------------- + g <- {-# SCC "setInfoTableStackMap" #-} + return $ map (setInfoTableStackMap platform stackmaps) g + dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g + + ----------- Control-flow optimisations ----------------------------- + g <- {-# SCC "cmmCfgOpts(2)" #-} + return $ if optLevel dflags >= 1 + then map (cmmCfgOptsProc splitting_proc_points) g + else g + g <- return (map removeUnreachableBlocksProc g) + -- See Note [unreachable blocks] + dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g + + return (Left (cafEnv, g)) where platform = targetPlatform dflags dump = dumpGraph dflags diff --git a/compiler/GHC/Cmm/ProcPoint.hs b/compiler/GHC/Cmm/ProcPoint.hs index 23dbc282d9..0cabea1536 100644 --- a/compiler/GHC/Cmm/ProcPoint.hs +++ b/compiler/GHC/Cmm/ProcPoint.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE GADTs, DisambiguateRecordFields, BangPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE GADTs #-} + {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Cmm.ProcPoint @@ -237,155 +240,152 @@ extendPPSet platform g blocks procPoints = -- Input invariant: A block should only be reachable from a single ProcPoint. -- ToDo: use the _ret naming convention that the old code generator -- used. -- EZY -splitAtProcPoints :: Platform -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status -> - CmmDecl -> UniqSM [CmmDecl] -splitAtProcPoints platform entry_label callPPs procPoints procMap - (CmmProc (TopInfo {info_tbls = info_tbls}) - top_l _ g@(CmmGraph {g_entry=entry})) = - do -- Build a map from procpoints to the blocks they reach - let add_block - :: LabelMap (LabelMap CmmBlock) - -> CmmBlock - -> LabelMap (LabelMap CmmBlock) - add_block graphEnv b = - case mapLookup bid procMap of - Just ProcPoint -> add graphEnv bid bid b - Just (ReachedBy set) -> - case setElems set of - [] -> graphEnv - [id] -> add graphEnv id bid b - _ -> panic "Each block should be reachable from only one ProcPoint" - Nothing -> graphEnv - where bid = entryLabel b - add graphEnv procId bid b = mapInsert procId graph' graphEnv - where graph = mapLookup procId graphEnv `orElse` mapEmpty - graph' = mapInsert bid b graph - - let liveness = cmmGlobalLiveness platform g - let ppLiveness pp = filter isArgReg $ - regSetToList $ - expectJust "ppLiveness" $ mapLookup pp liveness - - graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g - - -- Build a map from proc point BlockId to pairs of: - -- * Labels for their new procedures - -- * Labels for the info tables of their new procedures (only if - -- the proc point is a callPP) - -- Due to common blockification, we may overestimate the set of procpoints. - let add_label map pp = mapInsert pp lbls map - where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls)) - | otherwise = (block_lbl, guard (setMember pp callPPs) >> - Just info_table_lbl) - where block_lbl = blockLbl pp - info_table_lbl = infoTblLbl pp - - procLabels :: LabelMap (CLabel, Maybe CLabel) - procLabels = foldl' add_label mapEmpty - (filter (flip mapMember (toBlockMap g)) (setElems procPoints)) - - -- In each new graph, add blocks jumping off to the new procedures, - -- and replace branches to procpoints with branches to the jump-off blocks - let add_jump_block - :: (LabelMap Label, [CmmBlock]) - -> (Label, CLabel) - -> UniqSM (LabelMap Label, [CmmBlock]) - add_jump_block (env, bs) (pp, l) = - do bid <- liftM mkBlockId getUniqueM - let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump - live = ppLiveness pp - jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0 - return (mapInsert pp bid env, b : bs) - - add_jumps - :: LabelMap CmmGraph - -> (Label, LabelMap CmmBlock) - -> UniqSM (LabelMap CmmGraph) - add_jumps newGraphEnv (ppId, blockEnv) = - do let needed_jumps = -- find which procpoints we currently branch to - mapFoldr add_if_branch_to_pp [] blockEnv - add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)] - add_if_branch_to_pp block rst = - case lastNode block of - CmmBranch id -> add_if_pp id rst - CmmCondBranch _ ti fi _ -> add_if_pp ti (add_if_pp fi rst) - CmmSwitch _ ids -> foldr add_if_pp rst $ switchTargetsToList ids - _ -> rst - - -- when jumping to a PP that has an info table, if - -- tablesNextToCode is off we must jump to the entry - -- label instead. - tablesNextToCode = platformTablesNextToCode platform - jump_label (Just info_lbl) _ - | tablesNextToCode = info_lbl - | otherwise = toEntryLbl platform info_lbl - jump_label Nothing block_lbl = block_lbl - - add_if_pp id rst = case mapLookup id procLabels of - Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst - Nothing -> rst - (jumpEnv, jumpBlocks) <- - foldM add_jump_block (mapEmpty, []) needed_jumps - -- update the entry block - let b = expectJust "block in env" $ mapLookup ppId blockEnv - blockEnv' = mapInsert ppId b blockEnv - -- replace branches to procpoints with branches to jumps - blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv' - -- add the jump blocks to the graph - blockEnv''' = foldl' (flip addBlock) blockEnv'' jumpBlocks - let g' = ofBlockMap ppId blockEnv''' - -- pprTrace "g' pre jumps" (ppr g') $ do - return (mapInsert ppId g' newGraphEnv) - - graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv - - let to_proc (bid, g) - | bid == entry - = CmmProc (TopInfo {info_tbls = info_tbls, - stack_info = stack_info}) - top_l live g' - | otherwise - = case expectJust "pp label" $ mapLookup bid procLabels of - (lbl, Just info_lbl) - -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl) - , stack_info=stack_info}) - lbl live g' - (lbl, Nothing) - -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info}) - lbl live g' - where - g' = replacePPIds g - live = ppLiveness (g_entry g') - stack_info = StackInfo { arg_space = 0 - , do_layout = True } - -- cannot use panic, this is printed by -ddump-cmm - - -- References to procpoint IDs can now be replaced with the - -- infotable's label - replacePPIds g = {-# SCC "replacePPIds" #-} - mapGraphNodes (id, mapExp repl, mapExp repl) g - where repl e@(CmmLit (CmmBlock bid)) = - case mapLookup bid procLabels of - Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl) - _ -> e - repl e = e - - -- The C back end expects to see return continuations before the - -- call sites. Here, we sort them in reverse order -- it gets - -- reversed later. - let (_, block_order) = - foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int) - (revPostorder g) - add_block_num (i, map) block = - (i + 1, mapInsert (entryLabel block) i map) - sort_fn (bid, _) (bid', _) = - compare (expectJust "block_order" $ mapLookup bid block_order) - (expectJust "block_order" $ mapLookup bid' block_order) - procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv - return -- pprTrace "procLabels" (ppr procLabels) - -- pprTrace "splitting graphs" (ppr procs) - procs +splitAtProcPoints :: Platform -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status -> CmmDecl + -> UniqSM [CmmDecl] splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t] +splitAtProcPoints platform entry_label callPPs procPoints procMap cmmProc = do + -- Build a map from procpoints to the blocks they reach + let (CmmProc (TopInfo {info_tbls = info_tbls}) top_l _ g@(CmmGraph {g_entry=entry})) = cmmProc + + let add graphEnv procId bid b = mapInsert procId graph' graphEnv + where + graph' = mapInsert bid b graph + graph = mapLookup procId graphEnv `orElse` mapEmpty + + let add_block :: LabelMap (LabelMap CmmBlock) -> CmmBlock -> LabelMap (LabelMap CmmBlock) + add_block graphEnv b = + case mapLookup bid procMap of + Just ProcPoint -> add graphEnv bid bid b + Just (ReachedBy set) -> + case setElems set of + [] -> graphEnv + [id] -> add graphEnv id bid b + _ -> panic "Each block should be reachable from only one ProcPoint" + Nothing -> graphEnv + where + bid = entryLabel b + + + let liveness = cmmGlobalLiveness platform g + let ppLiveness pp = filter isArgReg $ regSetToList $ + expectJust "ppLiveness" $ mapLookup pp liveness + graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g + + -- Build a map from proc point BlockId to pairs of: + -- * Labels for their new procedures + -- * Labels for the info tables of their new procedures (only if + -- the proc point is a callPP) + -- Due to common blockification, we may overestimate the set of procpoints. + let add_label map pp = mapInsert pp lbls map + where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls)) + | otherwise = (block_lbl, guard (setMember pp callPPs) >> + Just info_table_lbl) + where block_lbl = blockLbl pp + info_table_lbl = infoTblLbl pp + + procLabels :: LabelMap (CLabel, Maybe CLabel) + procLabels = foldl' add_label mapEmpty + (filter (flip mapMember (toBlockMap g)) (setElems procPoints)) + + -- In each new graph, add blocks jumping off to the new procedures, + -- and replace branches to procpoints with branches to the jump-off blocks + let add_jump_block :: (LabelMap Label, [CmmBlock]) + -> (Label, CLabel) + -> UniqSM (LabelMap Label, [CmmBlock]) + add_jump_block (env, bs) (pp, l) = do + bid <- liftM mkBlockId getUniqueM + let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump + live = ppLiveness pp + jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0 + return (mapInsert pp bid env, b : bs) + + -- when jumping to a PP that has an info table, if + -- tablesNextToCode is off we must jump to the entry + -- label instead. + let tablesNextToCode = platformTablesNextToCode platform + + let jump_label (Just info_lbl) _ + | tablesNextToCode = info_lbl + | otherwise = toEntryLbl platform info_lbl + jump_label Nothing block_lbl = block_lbl + + let add_if_pp id rst = + case mapLookup id procLabels of + Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst + Nothing -> rst + + let add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)] + add_if_branch_to_pp block rst = + case lastNode block of + CmmBranch id -> add_if_pp id rst + CmmCondBranch _ ti fi _ -> add_if_pp ti (add_if_pp fi rst) + CmmSwitch _ ids -> foldr add_if_pp rst $ switchTargetsToList ids + _ -> rst + + let add_jumps :: LabelMap CmmGraph -> (Label, LabelMap CmmBlock) -> UniqSM (LabelMap CmmGraph) + add_jumps newGraphEnv (ppId, blockEnv) = do + -- find which procpoints we currently branch to + let needed_jumps = mapFoldr add_if_branch_to_pp [] blockEnv + + (jumpEnv, jumpBlocks) <- + foldM add_jump_block (mapEmpty, []) needed_jumps + -- update the entry block + let b = expectJust "block in env" $ mapLookup ppId blockEnv + blockEnv' = mapInsert ppId b blockEnv + -- replace branches to procpoints with branches to jumps + blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv' + -- add the jump blocks to the graph + blockEnv''' = foldl' (flip addBlock) blockEnv'' jumpBlocks + let g' = ofBlockMap ppId blockEnv''' + -- pprTrace "g' pre jumps" (ppr g') $ do + return (mapInsert ppId g' newGraphEnv) + + graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv + + let to_proc (bid, g) + | bid == entry + = CmmProc (TopInfo {info_tbls = info_tbls, + stack_info = stack_info}) + top_l live g' + | otherwise + = case expectJust "pp label" $ mapLookup bid procLabels of + (lbl, Just info_lbl) + -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl) + , stack_info=stack_info}) + lbl live g' + (lbl, Nothing) + -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info}) + lbl live g' + where + g' = replacePPIds g + live = ppLiveness (g_entry g') + stack_info = StackInfo { arg_space = 0 + , do_layout = True } + -- cannot use panic, this is printed by -ddump-cmm + + -- References to procpoint IDs can now be replaced with the + -- infotable's label + replacePPIds g = {-# SCC "replacePPIds" #-} + mapGraphNodes (id, mapExp repl, mapExp repl) g + where repl e@(CmmLit (CmmBlock bid)) = + case mapLookup bid procLabels of + Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl) + _ -> e + repl e = e + + -- The C back end expects to see return continuations before the + -- call sites. Here, we sort them in reverse order -- it gets + -- reversed later. + let add_block_num (i, map) block = + (i + 1, mapInsert (entryLabel block) i map) + let (_, block_order) = + foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int) + (revPostorder g) + let sort_fn (bid, _) (bid', _) = + compare (expectJust "block_order" $ mapLookup bid block_order) + (expectJust "block_order" $ mapLookup bid' block_order) + + return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv -- Only called from GHC.Cmm.ProcPoint.splitAtProcPoints. NB. does a -- recursive lookup, see comment below. diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs index 7112d603b6..09ff24e96f 100644 --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -1101,30 +1101,28 @@ cmmExprNative referenceKind expr = do arch = platformArch platform case expr of CmmLoad addr rep - -> do addr' <- cmmExprNative DataReference addr - return $ CmmLoad addr' rep + -> do addr' <- cmmExprNative DataReference addr + return $ CmmLoad addr' rep CmmMachOp mop args - -> do args' <- mapM (cmmExprNative DataReference) args - return $ CmmMachOp mop args' + -> do args' <- mapM (cmmExprNative DataReference) args + return $ CmmMachOp mop args' CmmLit (CmmBlock id) - -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id))) - -- we must convert block Ids to CLabels here, because we - -- might have to do the PIC transformation. Hence we must - -- not modify BlockIds beyond this point. + -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id))) + -- we must convert block Ids to CLabels here, because we + -- might have to do the PIC transformation. Hence we must + -- not modify BlockIds beyond this point. CmmLit (CmmLabel lbl) - -> do - cmmMakeDynamicReference config referenceKind lbl + -> cmmMakeDynamicReference config referenceKind lbl CmmLit (CmmLabelOff lbl off) - -> do - dynRef <- cmmMakeDynamicReference config referenceKind lbl - -- need to optimize here, since it's late - return $ cmmMachOpFold platform (MO_Add (wordWidth platform)) [ - dynRef, - (CmmLit $ CmmInt (fromIntegral off) (wordWidth platform)) - ] + -> do dynRef <- cmmMakeDynamicReference config referenceKind lbl + -- need to optimize here, since it's late + return $ cmmMachOpFold platform (MO_Add (wordWidth platform)) [ + dynRef, + (CmmLit $ CmmInt (fromIntegral off) (wordWidth platform)) + ] -- On powerpc (non-PIC), it's easier to jump directly to a label than -- to use the register table, so we replace these registers diff --git a/compiler/GHC/CmmToAsm/BlockLayout.hs b/compiler/GHC/CmmToAsm/BlockLayout.hs index 0a71d00449..d32357b5cc 100644 --- a/compiler/GHC/CmmToAsm/BlockLayout.hs +++ b/compiler/GHC/CmmToAsm/BlockLayout.hs @@ -475,7 +475,6 @@ combineNeighbourhood edges chains applyEdges edges newEnds newFronts (Set.insert (from,to) combined) | otherwise = applyEdges edges chainEnds chainFronts combined - where getFronts chain = takeL neighbourOverlapp chain getEnds chain = takeR neighbourOverlapp chain @@ -588,19 +587,14 @@ buildChains edges blocks , Just predChain <- mapLookup from chainEnds , Just succChain <- mapLookup to chainStarts , predChain /= succChain -- Otherwise we try to create a cycle. - = do - -- pprTraceM "Fusing edge" (ppr edge) - fuseChain predChain succChain + = fuseChain predChain succChain | (alreadyPlaced from) && (alreadyPlaced to) - = --pprTraceM "Skipping:" (ppr edge) >> - buildNext placed chainStarts chainEnds todo linked + = buildNext placed chainStarts chainEnds todo linked | otherwise - = do -- pprTraceM "Finding chain for:" (ppr edge $$ - -- text "placed" <+> ppr placed) - findChain + = findChain where from = edgeFrom edge to = edgeTo edge diff --git a/compiler/GHC/CmmToAsm/CFG/Dominators.hs b/compiler/GHC/CmmToAsm/CFG/Dominators.hs index d9edc86cee..92ef5d95ec 100644 --- a/compiler/GHC/CmmToAsm/CFG/Dominators.hs +++ b/compiler/GHC/CmmToAsm/CFG/Dominators.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE RankNTypes, BangPatterns, FlexibleContexts, Strict #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Strict #-} {- | Module : GHC.CmmToAsm.CFG.Dominators @@ -250,7 +253,7 @@ link v w = do zw <- sizeM w store labelE s lw store sizeE v . (+zw) =<< sizeM v - let follow s = do + let follow s = when (s /= n0) (do store ancestorE s v follow =<< childM s) diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs index b25e6187b9..01a3a67333 100644 --- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP, GADTs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- @@ -117,7 +118,7 @@ cmmTopCodeGen (CmmProc info lab live graph) = do return (CmmProc info lab live (ListGraph (b':blocks)) : statics) fixup_entry _ = panic "cmmTopCodegen: Broken CmmProc" -cmmTopCodeGen (CmmData sec dat) = do +cmmTopCodeGen (CmmData sec dat) = return [CmmData sec dat] -- no translation, we just use CmmStatic basicBlockCodeGen @@ -787,7 +788,7 @@ getAmode DS (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)]) (reg, code) <- getSomeReg x (reg', off', code') <- if i `mod` 4 == 0 - then do return (reg, off, code) + then return (reg, off, code) else do tmp <- getNewRegNat II64 return (tmp, ImmInt 0, @@ -800,7 +801,7 @@ getAmode DS (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)]) (reg, code) <- getSomeReg x (reg', off', code') <- if i `mod` 4 == 0 - then do return (reg, off, code) + then return (reg, off, code) else do tmp <- getNewRegNat II64 return (tmp, ImmInt 0, @@ -882,8 +883,7 @@ getCondCode :: CmmExpr -> NatM CondCode -- extend small integers to 32 bit or 64 bit first getCondCode (CmmMachOp mop [x, y]) - = do - case mop of + = case mop of MO_F_Eq W32 -> condFltCode EQQ x y MO_F_Ne W32 -> condFltCode NE x y MO_F_Gt W32 -> condFltCode GTT x y @@ -1670,7 +1670,7 @@ genCCall' config gcp target dest_regs args codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32 case labelOrExpr of - Left lbl -> do -- the linker does all the work for us + Left lbl -> -- the linker does all the work for us return ( codeBefore `snocOL` BL lbl usedRegs `appOL` maybeNOP -- some ABI require a NOP after BL @@ -1716,7 +1716,7 @@ genCCall' config gcp target dest_regs args where platform = ncgPlatform config - uses_pic_base_implicitly = do + uses_pic_base_implicitly = -- See Note [implicit register in PPC PIC code] -- on why we claim to use PIC register here when (ncgPIC config && target32Bit platform) $ do diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs index b3c06cefcc..e290be505e 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs @@ -1,4 +1,3 @@ - -- | When there aren't enough registers to hold all the vregs we have to spill -- some of those vregs to slots on the stack. This module is used modify the -- code to use those slots. @@ -7,6 +6,7 @@ module GHC.CmmToAsm.Reg.Graph.Spill ( SpillStats(..), accSpillSL ) where + import GHC.Prelude import GHC.CmmToAsm.Reg.Liveness @@ -182,46 +182,41 @@ regSpill_instr -> UniqFM Reg Int -- ^ map of vregs to slots they're being spilled to. -> LiveInstr instr -> SpillM [LiveInstr instr] - -regSpill_instr _ _ li@(LiveInstr _ Nothing) - = do return [li] - -regSpill_instr platform regSlotMap - (LiveInstr instr (Just _)) - = do - -- work out which regs are read and written in this instr - let RU rlRead rlWritten = regUsageOfInstr platform instr - - -- sometimes a register is listed as being read more than once, - -- nub this so we don't end up inserting two lots of spill code. - let rsRead_ = nub rlRead - let rsWritten_ = nub rlWritten - - -- if a reg is modified, it appears in both lists, want to undo this.. - let rsRead = rsRead_ \\ rsWritten_ - let rsWritten = rsWritten_ \\ rsRead_ - let rsModify = intersect rsRead_ rsWritten_ - - -- work out if any of the regs being used are currently being spilled. - let rsSpillRead = filter (\r -> elemUFM r regSlotMap) rsRead - let rsSpillWritten = filter (\r -> elemUFM r regSlotMap) rsWritten - let rsSpillModify = filter (\r -> elemUFM r regSlotMap) rsModify - - -- rewrite the instr and work out spill code. - (instr1, prepost1) <- mapAccumLM (spillRead regSlotMap) instr rsSpillRead - (instr2, prepost2) <- mapAccumLM (spillWrite regSlotMap) instr1 rsSpillWritten - (instr3, prepost3) <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify - - let (mPrefixes, mPostfixes) = unzip (prepost1 ++ prepost2 ++ prepost3) - let prefixes = concat mPrefixes - let postfixes = concat mPostfixes - - -- final code - let instrs' = prefixes - ++ [LiveInstr instr3 Nothing] - ++ postfixes - - return $ instrs' +regSpill_instr _ _ li@(LiveInstr _ Nothing) = return [li] +regSpill_instr platform regSlotMap (LiveInstr instr (Just _)) = do + -- work out which regs are read and written in this instr + let RU rlRead rlWritten = regUsageOfInstr platform instr + + -- sometimes a register is listed as being read more than once, + -- nub this so we don't end up inserting two lots of spill code. + let rsRead_ = nub rlRead + let rsWritten_ = nub rlWritten + + -- if a reg is modified, it appears in both lists, want to undo this.. + let rsRead = rsRead_ \\ rsWritten_ + let rsWritten = rsWritten_ \\ rsRead_ + let rsModify = intersect rsRead_ rsWritten_ + + -- work out if any of the regs being used are currently being spilled. + let rsSpillRead = filter (\r -> elemUFM r regSlotMap) rsRead + let rsSpillWritten = filter (\r -> elemUFM r regSlotMap) rsWritten + let rsSpillModify = filter (\r -> elemUFM r regSlotMap) rsModify + + -- rewrite the instr and work out spill code. + (instr1, prepost1) <- mapAccumLM (spillRead regSlotMap) instr rsSpillRead + (instr2, prepost2) <- mapAccumLM (spillWrite regSlotMap) instr1 rsSpillWritten + (instr3, prepost3) <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify + + let (mPrefixes, mPostfixes) = unzip (prepost1 ++ prepost2 ++ prepost3) + let prefixes = concat mPrefixes + let postfixes = concat mPostfixes + + -- final code + let instrs' = prefixes + ++ [LiveInstr instr3 Nothing] + ++ postfixes + + return instrs' -- | Add a RELOAD met a instruction to load a value for an instruction that diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs index 13a9ef4f9e..c06d4178ad 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs @@ -73,7 +73,7 @@ cmmTopCodeGen (CmmProc info lab live graph) return tops -cmmTopCodeGen (CmmData sec dat) = do +cmmTopCodeGen (CmmData sec dat) = return [CmmData sec dat] -- no translation, we just use CmmStatic @@ -430,8 +430,8 @@ genCCall target dest_regs args PrimTarget mop -> do res <- outOfLineMachOp mop - lblOrMopExpr <- case res of - Left lbl -> do + case res of + Left lbl -> return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) Right mopExpr -> do @@ -441,8 +441,6 @@ genCCall target dest_regs args _ -> panic "SPARC.CodeGen.genCCall: arg_to_int" return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) - return lblOrMopExpr - let argcode = concatOL argcodes let (move_sp_down, move_sp_up) diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs index aa4769f376..e59ddb01cc 100644 --- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE CPP, GADTs, NondecreasingIndentation #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE TupleSections #-} #if __GLASGOW_HASKELL__ <= 808 -- GHC 8.10 deprecates this flag, but GHC 8.8 needs it @@ -131,7 +133,7 @@ cmmTopCodeGen (CmmProc info lab live graph) = do Just picBase -> initializePicBase_x86 ArchX86 os picBase tops Nothing -> return tops -cmmTopCodeGen (CmmData sec dat) = do +cmmTopCodeGen (CmmData sec dat) = return [CmmData sec (mkAlignment 1, dat)] -- no translation, we just use CmmStatic {- Note [Verifying basic blocks] @@ -750,11 +752,11 @@ getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _]) getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), CmmLit displacement]) - | not is32Bit = do + | not is32Bit = return $ Any II64 (\dst -> unitOL $ LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst)) -getRegister' platform is32Bit (CmmMachOp mop [x]) = do -- unary MachOps +getRegister' platform is32Bit (CmmMachOp mop [x]) = -- unary MachOps case mop of MO_F_Neg w -> sse2NegCode w x @@ -886,7 +888,7 @@ getRegister' platform is32Bit (CmmMachOp mop [x]) = do -- unary MachOps return (swizzleRegisterRep e_code new_format) -getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps +getRegister' _ is32Bit (CmmMachOp mop [x, y]) = -- dyadic MachOps case mop of MO_F_Eq _ -> condFltReg is32Bit EQQ x y MO_F_Ne _ -> condFltReg is32Bit NE x y @@ -1371,17 +1373,16 @@ x86_complex_amode base index shift offset -- (see trivialCode where this function is used for an example). getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock) -getNonClobberedOperand (CmmLit lit) = do +getNonClobberedOperand (CmmLit lit) = if isSuitableFloatingPointLit lit - then do - let CmmFloat _ w = lit - Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit - return (OpAddr addr, code) - else do - - is32Bit <- is32BitPlatform - platform <- getPlatform - if is32BitLit is32Bit lit && not (isFloatType (cmmLitType platform lit)) + then do + let CmmFloat _ w = lit + Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit + return (OpAddr addr, code) + else do + is32Bit <- is32BitPlatform + platform <- getPlatform + if is32BitLit is32Bit lit && not (isFloatType (cmmLitType platform lit)) then return (OpImm (litToImm lit), nilOL) else getNonClobberedOperand_generic (CmmLit lit) @@ -1407,7 +1408,7 @@ getNonClobberedOperand (CmmLoad mem pk) = do else return (src, nilOL) return (OpAddr src', mem_code `appOL` save_code) - else do + else -- if its a word or gcptr on 32bit? getNonClobberedOperand_generic (CmmLoad mem pk) @@ -1415,8 +1416,8 @@ getNonClobberedOperand e = getNonClobberedOperand_generic e getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock) getNonClobberedOperand_generic e = do - (reg, code) <- getNonClobberedReg e - return (OpReg reg, code) + (reg, code) <- getNonClobberedReg e + return (OpReg reg, code) amodeCouldBeClobbered :: Platform -> AddrMode -> Bool amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode) @@ -1795,7 +1796,7 @@ genJump (CmmLoad mem _) regs = do Amode target code <- getAmode mem return (code `snocOL` JMP (OpAddr target) regs) -genJump (CmmLit lit) regs = do +genJump (CmmLit lit) regs = return (unitOL (JMP (OpImm (litToImm lit)) regs)) genJump expr regs = do diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs index 78f22e5710..5c0f08f641 100644 --- a/compiler/GHC/CmmToLlvm/CodeGen.hs +++ b/compiler/GHC/CmmToLlvm/CodeGen.hs @@ -188,18 +188,18 @@ barrierUnless exs = do else barrier -- | Foreign Calls -genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] - -> LlvmM StmtData +genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData -- Barriers need to be handled specially as they are implemented as LLVM -- intrinsic functions. genCall (PrimTarget MO_ReadBarrier) _ _ = barrierUnless [ArchX86, ArchX86_64, ArchSPARC] -genCall (PrimTarget MO_WriteBarrier) _ _ = do + +genCall (PrimTarget MO_WriteBarrier) _ _ = barrierUnless [ArchX86, ArchX86_64, ArchSPARC] -genCall (PrimTarget MO_Touch) _ _ - = return (nilOL, []) +genCall (PrimTarget MO_Touch) _ _ = + return (nilOL, []) genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = runStmtsDecls $ do dstV <- getCmmRegW (CmmLocal dst) @@ -514,9 +514,8 @@ genCall target res args = do -- make the actual call case retTy of - LMVoid -> do + LMVoid -> statement $ Expr $ Call ccTy fptr argVars fnAttrs - _ -> do v1 <- doExprW retTy $ Call ccTy fptr argVars fnAttrs -- get the return register @@ -1559,9 +1558,8 @@ genMachOp_slow opt op [x, y] = case op of vx <- exprToVarW x vy <- exprToVarW y if getVarType vx == getVarType vy - then do + then doExprW (ty vx) $ binOp vx vy - else do -- Error. Continue anyway so we can debug the generated ll file. dflags <- getDynFlags @@ -1717,19 +1715,19 @@ genLoad_slow atomic e ty meta = do runExprData $ do iptr <- exprToVarW e case getVarType iptr of - LMPointer _ -> do + LMPointer _ -> doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr iptr) - i@(LMInt _) | i == llvmWord platform -> do + i@(LMInt _) | i == llvmWord platform -> do let pty = LMPointer $ cmmToLlvmType ty ptr <- doExprW pty $ Cast LM_Inttoptr iptr pty doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr ptr) - other -> do pprPanic "exprToVar: CmmLoad expression is not right type!" - (PprCmm.pprExpr platform e <+> text ( - "Size of Ptr: " ++ show (llvmPtrBits platform) ++ - ", Size of var: " ++ show (llvmWidthInBits platform other) ++ - ", Var: " ++ showSDoc dflags (ppVar opts iptr))) + other -> pprPanic "exprToVar: CmmLoad expression is not right type!" + (PprCmm.pprExpr platform e <+> text ( + "Size of Ptr: " ++ show (llvmPtrBits platform) ++ + ", Size of var: " ++ show (llvmWidthInBits platform other) ++ + ", Var: " ++ showSDoc dflags (ppVar opts iptr))) where loadInstr ptr | atomic = ALoad SyncSeqCst False ptr | otherwise = Load ptr diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 6fdcb02c8c..5104b00c61 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -51,7 +51,6 @@ import GHC.Types.Name.Env import GHC.Types.Id import GHC.Types.Id.Info import GHC.Core.Ppr -import GHC.Utils.Error import GHC.Core.Coercion import GHC.Types.SrcLoc import GHC.Core.Type as Type @@ -402,7 +401,6 @@ displayLintResults dflags pass warns errs binds (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) | otherwise = return () - where lint_banner :: String -> SDoc -> SDoc lint_banner string pass = text "*** Core Lint" <+> text string @@ -925,7 +923,7 @@ lintCoreExpr e@(App _ _) ; (fun_ty2, ue2) <- lintCoreArg fun_pair1 arg_ty2 -- See Note [Linting of runRW#] ; let lintRunRWCont :: CoreArg -> LintM (LintedType, UsageEnv) - lintRunRWCont expr@(Lam _ _) = do + lintRunRWCont expr@(Lam _ _) = lintJoinLams 1 (Just fun) expr lintRunRWCont other = markAllJoinsBad $ lintCoreExpr other -- TODO: Look through ticks? diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index cb3b0a2a05..73b266de11 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -43,7 +43,7 @@ import GHC.Core import GHC.Core.Make import GHC.Types.Id import GHC.Types.Literal -import GHC.Core.SimpleOpt ( exprIsLiteral_maybe ) +import GHC.Core.SimpleOpt ( exprIsConApp_maybe, exprIsLiteral_maybe ) import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey ) import GHC.Builtin.Types import GHC.Builtin.Types.Prim @@ -54,7 +54,6 @@ import GHC.Core.TyCon import GHC.Core.DataCon ( dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId ) import GHC.Core.Utils ( eqExpr, cheapEqExpr, exprIsHNF, exprType , stripTicksTop, stripTicksTopT, mkTicks ) -import GHC.Core.SimpleOpt ( exprIsConApp_maybe ) import GHC.Core.Multiplicity import GHC.Core.FVs import GHC.Core.Type @@ -447,7 +446,7 @@ intOp2' _ _ _ _ = Nothing intOpC2 :: (Integral a, Integral b) => (a -> b -> Integer) -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr -intOpC2 op env (LitNumber LitNumInt i1) (LitNumber LitNumInt i2) = do +intOpC2 op env (LitNumber LitNumInt i1) (LitNumber LitNumInt i2) = intCResult (roPlatform env) (fromInteger i1 `op` fromInteger i2) intOpC2 _ _ _ _ = Nothing diff --git a/compiler/GHC/Core/Opt/Exitify.hs b/compiler/GHC/Core/Opt/Exitify.hs index 60b1e7a61c..d806e9c607 100644 --- a/compiler/GHC/Core/Opt/Exitify.hs +++ b/compiler/GHC/Core/Opt/Exitify.hs @@ -116,7 +116,7 @@ exitifyRec in_scope pairs -- Which are the recursive calls? recursive_calls = mkVarSet $ map fst pairs - (pairs',exits) = (`runState` []) $ do + (pairs',exits) = (`runState` []) $ forM ann_pairs $ \(x,rhs) -> do -- go past the lambdas of the join point let (args, body) = collectNAnnBndrs (idJoinArity x) rhs diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs index c535c24638..bdacfba90b 100644 --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/compiler/GHC/Core/Opt/Monad.hs @@ -65,9 +65,8 @@ import GHC.Types.Name.Env import GHC.Types.SrcLoc import GHC.Utils.Outputable as Outputable -import GHC.Utils.Error( Severity(..), DumpFormat (..), dumpOptionsFromFlag ) +import GHC.Utils.Error ( Severity(..), DumpFormat (..), dumpAction, dumpOptionsFromFlag ) import GHC.Utils.Monad -import GHC.Utils.Error (dumpAction) import GHC.Data.FastString import GHC.Data.IOEnv hiding ( liftIO, failM, failWithM ) diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index c8e10865cb..f393255b54 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -461,7 +461,7 @@ runCorePasses passes guts where do_pass guts CoreDoNothing = return guts do_pass guts (CoreDoPasses ps) = runCorePasses ps guts - do_pass guts pass = do + do_pass guts pass = withTimingD (ppr pass <+> brackets (ppr mod)) (const ()) $ do { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 42cc081498..15bf703639 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -17,13 +17,11 @@ import GHC.Platform import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Driver.Config -import GHC.Core.SimpleOpt ( exprIsConApp_maybe ) import GHC.Core.Opt.Simplify.Monad import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst ) import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Utils import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) -import GHC.Core.FamInstEnv ( FamInstEnv ) import GHC.Types.Literal ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326 import GHC.Types.SourceText import GHC.Types.Id @@ -34,7 +32,7 @@ import GHC.Types.Id.Info import GHC.Types.Name ( mkSystemVarName, isExternalName, getOccFS ) import GHC.Core.Coercion hiding ( substCo, substCoVar ) import GHC.Core.Coercion.Opt ( optCoercion ) -import GHC.Core.FamInstEnv ( topNormaliseType_maybe ) +import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe ) import GHC.Core.DataCon ( DataCon, dataConWorkId, dataConRepStrictness , dataConRepArgTys, isUnboxedTupleDataCon @@ -54,7 +52,7 @@ import GHC.Core.Utils import GHC.Core.Opt.Arity ( ArityType(..), arityTypeArity, isBotArityType , pushCoTyArg, pushCoValArg , idArityType, etaExpandAT ) -import GHC.Core.SimpleOpt ( joinPointBinding_maybe, joinPointBindings_maybe ) +import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) import GHC.Core.FVs ( mkRuleInfo ) import GHC.Core.Rules ( lookupRule, getRules, initRuleOpts ) import GHC.Types.Basic @@ -2197,21 +2195,21 @@ tryRules env rules fn args call_cont nodump | dopt Opt_D_dump_rule_rewrites dflags - = liftIO $ do - touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_rewrites) + = liftIO $ + touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_rewrites) | dopt Opt_D_dump_rule_firings dflags - = liftIO $ do - touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_firings) + = liftIO $ + touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_firings) | otherwise = return () log_rule dflags flag hdr details = liftIO $ do - let sty = mkDumpStyle alwaysQualify - dumpAction dflags sty (dumpOptionsFromFlag flag) "" FormatText $ - sep [text hdr, nest 4 details] + let sty = mkDumpStyle alwaysQualify + dumpAction dflags sty (dumpOptionsFromFlag flag) "" FormatText $ + sep [text hdr, nest 4 details] trySeqRules :: SimplEnv -> OutExpr -> InExpr -- Scrutinee and RHS diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index 2ca8e1a080..c613ac2ebd 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -1066,14 +1066,6 @@ nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv } combineCalls :: CallEnv -> CallEnv -> CallEnv combineCalls = plusVarEnv_C (++) - where --- plus cs ds | length res > 1 --- = pprTrace "combineCalls" (vcat [ text "cs:" <+> ppr cs --- , text "ds:" <+> ppr ds]) --- res --- | otherwise = res --- where --- res = cs ++ ds combineUsage :: ScUsage -> ScUsage -> ScUsage combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2), diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index 2fa9e9b18c..4cca5199c7 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -724,8 +724,7 @@ spec_import top_env callers rb dict_binds cis@(CIS fn _) -- call to the original function | null good_calls - = do { -- debugTraceMsg (text "specImport:no valid calls") - ; return ([], []) } + = return ([], []) | Just rhs <- canSpecImport dflags fn = do { -- Get rules from the external package state @@ -738,9 +737,8 @@ spec_import top_env callers rb dict_binds cis@(CIS fn _) rules_for_fn = getRules (RuleEnv full_rb vis_orphs) fn ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls }) - <- do { -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs]) - ; runSpecM $ - specCalls True top_env rules_for_fn good_calls fn rhs } + <- -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs]) >> + (runSpecM $ specCalls True top_env rules_for_fn good_calls fn rhs) ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs] -- After the rules kick in we may get recursion, but -- we rely on a global GlomBinds to sort that out later diff --git a/compiler/GHC/Core/Opt/StaticArgs.hs b/compiler/GHC/Core/Opt/StaticArgs.hs index 04b21b588e..180d555c2f 100644 --- a/compiler/GHC/Core/Opt/StaticArgs.hs +++ b/compiler/GHC/Core/Opt/StaticArgs.hs @@ -189,7 +189,7 @@ satExpr var@(Var v) interesting_ids = do else Nothing return (var, emptyIdSATInfo, app_info) -satExpr lit@(Lit _) _ = do +satExpr lit@(Lit _) _ = return (lit, emptyIdSATInfo, Nothing) satExpr (Lam binders body) interesting_ids = do @@ -238,10 +238,10 @@ satExpr (Tick tickish expr) interesting_ids = do (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids return (Tick tickish expr', sat_info_expr, expr_app) -satExpr ty@(Type _) _ = do +satExpr ty@(Type _) _ = return (ty, emptyIdSATInfo, Nothing) -satExpr co@(Coercion _) _ = do +satExpr co@(Coercion _) _ = return (co, emptyIdSATInfo, Nothing) satExpr (Cast expr coercion) interesting_ids = do diff --git a/compiler/GHC/Core/TyCon/Env.hs b/compiler/GHC/Core/TyCon/Env.hs index f2ec25ba0d..76edb829fd 100644 --- a/compiler/GHC/Core/TyCon/Env.hs +++ b/compiler/GHC/Core/TyCon/Env.hs @@ -5,9 +5,7 @@ \section[TyConEnv]{@TyConEnv@: tyCon environments} -} -{-# LANGUAGE CPP, DeriveDataTypeable #-} - -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/compiler/GHC/Core/TyCon/RecWalk.hs b/compiler/GHC/Core/TyCon/RecWalk.hs index 09ba6402ac..7ddb2eb4d2 100644 --- a/compiler/GHC/Core/TyCon/RecWalk.hs +++ b/compiler/GHC/Core/TyCon/RecWalk.hs @@ -6,7 +6,7 @@ Check for recursive type constructors. -} -{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} module GHC.Core.TyCon.RecWalk ( diff --git a/compiler/GHC/Core/TyCon/Set.hs b/compiler/GHC/Core/TyCon/Set.hs index 40beac6c58..d2615dfd73 100644 --- a/compiler/GHC/Core/TyCon/Set.hs +++ b/compiler/GHC/Core/TyCon/Set.hs @@ -4,7 +4,7 @@ -} -{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} module GHC.Core.TyCon.Set ( -- * TyCons set type diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index e980c560e0..2e40ddc659 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -74,7 +74,7 @@ import GHC.Platform import GHC.Driver.Ppr import GHC.Core -import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofName ) +import GHC.Builtin.Names (absentErrorIdKey, makeStaticName, unsafeEqualityProofName) import GHC.Core.Ppr import GHC.Core.FVs( exprFreeVars ) import GHC.Types.Var @@ -87,7 +87,6 @@ import GHC.Core.DataCon import GHC.Builtin.PrimOps import GHC.Types.Id import GHC.Types.Id.Info -import GHC.Builtin.Names( absentErrorIdKey ) import GHC.Core.Type as Type import GHC.Core.Predicate import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder ) diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index 2361a041d3..e0c7ef2521 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -51,9 +51,10 @@ import GHC.Builtin.PrimOps ( PrimCall(..) ) import GHC.Types.SrcLoc ( mkGeneralSrcSpan ) import GHC.Builtin.Names ( unsafeEqualityProofName ) -import Data.List.NonEmpty (nonEmpty, toList) -import Data.Maybe (fromMaybe) import Control.Monad (ap) +import Data.List.NonEmpty (nonEmpty, toList) +import Data.Maybe (fromMaybe) +import Data.Tuple (swap) import qualified Data.Set as Set -- Note [Live vs free] @@ -309,14 +310,10 @@ coreTopBindToStg dflags this_mod env ccs (Rec pairs) -- generate StgTopBindings and CAF cost centres created for CAFs (ccs', stg_rhss) - = initCts dflags env' $ do - mapAccumLM (\ccs rhs -> do - (rhs', ccs') <- - coreToTopStgRhs dflags ccs this_mod rhs - return (ccs', rhs')) - ccs - pairs - + = initCts dflags env' $ + mapAccumLM (\ccs rhs -> swap <$> coreToTopStgRhs dflags ccs this_mod rhs) + ccs + pairs bind = StgTopLifted $ StgRec (zip binders stg_rhss) in (env', ccs', bind) @@ -467,10 +464,8 @@ coreToStgExpr e0@(Case scrut bndr _ alts) = do rhs2 <- coreToStgExpr rhs return (con, binders', rhs2) -coreToStgExpr (Let bind body) = do - coreToStgLet bind body - -coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e) +coreToStgExpr (Let bind body) = coreToStgLet bind body +coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e) mkStgAltType :: Id -> [CoreAlt] -> AltType mkStgAltType bndr alts diff --git a/compiler/GHC/Data/FastString.hs b/compiler/GHC/Data/FastString.hs index 771ce24146..0f6a26f75e 100644 --- a/compiler/GHC/Data/FastString.hs +++ b/compiler/GHC/Data/FastString.hs @@ -1,8 +1,12 @@ -- (c) The University of Glasgow, 1997-2006 -{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples, - GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + {-# OPTIONS_GHC -O2 -funbox-strict-fields #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected @@ -501,7 +505,7 @@ mkFastStringBytes !ptr !len = mkFastStringWith (mkNewFastStringShortByteString sbs) sbs newSBSFromPtr :: Ptr a -> Int -> IO ShortByteString -newSBSFromPtr (Ptr src#) (I# len#) = do +newSBSFromPtr (Ptr src#) (I# len#) = IO $ \s -> case newByteArray# len# s of { (# s, dst# #) -> case copyAddrToByteArray# src# dst# 0# len# s of { s -> diff --git a/compiler/GHC/Data/StringBuffer.hs b/compiler/GHC/Data/StringBuffer.hs index 11ddfe47bc..42ab89f8cc 100644 --- a/compiler/GHC/Data/StringBuffer.hs +++ b/compiler/GHC/Data/StringBuffer.hs @@ -6,7 +6,11 @@ Buffers for scanning string input stored in external arrays. -} -{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + {-# OPTIONS_GHC -O2 #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected @@ -124,8 +128,8 @@ hGetStringBufferBlock handle wanted hPutStringBuffer :: Handle -> StringBuffer -> IO () hPutStringBuffer hdl (StringBuffer buf len cur) - = do withForeignPtr (plusForeignPtr buf cur) $ \ptr -> - hPutBuf hdl ptr len + = withForeignPtr (plusForeignPtr buf cur) $ \ptr -> + hPutBuf hdl ptr len -- | Skip the byte-order mark if there is one (see #1744 and #6016), -- and return the new position of the handle in bytes. @@ -198,8 +202,8 @@ stringToStringBuffer str = nextChar :: StringBuffer -> (Char,StringBuffer) nextChar (StringBuffer buf len (I# cur#)) = -- Getting our fingers dirty a little here, but this is performance-critical - inlinePerformIO $ do - withForeignPtr buf $ \(Ptr a#) -> do + inlinePerformIO $ + withForeignPtr buf $ \(Ptr a#) -> case utf8DecodeCharAddr# (a# `plusAddr#` cur#) 0# of (# c#, nBytes# #) -> let cur' = I# (cur# +# nBytes#) in @@ -215,7 +219,7 @@ currentChar = fst . nextChar prevChar :: StringBuffer -> Char -> Char prevChar (StringBuffer _ _ 0) deflt = deflt prevChar (StringBuffer buf _ cur) _ = - inlinePerformIO $ do + inlinePerformIO $ withForeignPtr buf $ \p -> do p' <- utf8PrevChar (p `plusPtr` cur) return (fst (utf8DecodeChar p')) diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index 54961066d8..332023dd74 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -224,7 +224,7 @@ withBkpSession cid insts deps session_type do_this = do do_this withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a -withBkpExeSession deps do_this = do +withBkpExeSession deps do_this = withBkpSession (Indefinite (UnitId (fsLit "main"))) [] deps ExeSession do_this getSource :: IndefUnitId -> BkpM (LHsUnit HsComponentId) @@ -472,7 +472,7 @@ overHscDynFlags f hsc_env = hsc_env { hsc_dflags = f (hsc_dflags hsc_env) } -- | Run a 'BkpM' computation, with the nesting level bumped one. innerBkpM :: BkpM a -> BkpM a -innerBkpM do_this = do +innerBkpM do_this = -- NB: withTempSession mutates, so we don't have to worry -- about bkp_session being stale. updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this @@ -491,14 +491,14 @@ getEpsGhc = do -- | Run 'BkpM' in 'Ghc'. initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a -initBkpM file bkp m = do - reifyGhc $ \session -> do +initBkpM file bkp m = + reifyGhc $ \session -> do let env = BkpEnv { - bkp_session = session, - bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp], - bkp_filename = file, - bkp_level = 0 - } + bkp_session = session, + bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp], + bkp_filename = file, + bkp_level = 0 + } runIOEnv env m -- ---------------------------------------------------------------------------- @@ -666,7 +666,7 @@ hsunitModuleGraph unit = do -- 1. Create a HsSrcFile/HsigFile summary for every -- explicitly mentioned module/signature. - let get_decl (L _ (DeclD hsc_src lmodname mb_hsmod)) = do + let get_decl (L _ (DeclD hsc_src lmodname mb_hsmod)) = Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod get_decl _ = return Nothing nodes <- catMaybes `fmap` mapM get_decl decls diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index f9912ee303..4886d5a2ee 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -131,17 +131,15 @@ outputC :: DynFlags -> Stream IO RawCmmGroup a -> [UnitId] -> IO a - -outputC dflags filenm cmm_stream packages - = do - withTiming dflags (text "C codegen") (\a -> seq a () {- FIXME -}) $ do - let pkg_names = map unitIdString packages - doOutput filenm $ \ h -> do - hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") - hPutStr h "#include \"Stg.h\"\n" - let platform = targetPlatform dflags - writeC = printForC dflags h . cmmToC platform - Stream.consume cmm_stream writeC +outputC dflags filenm cmm_stream packages = + withTiming dflags (text "C codegen") (\a -> seq a () {- FIXME -}) $ do + let pkg_names = map unitIdString packages + doOutput filenm $ \ h -> do + hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") + hPutStr h "#include \"Stg.h\"\n" + let platform = targetPlatform dflags + writeC = printForC dflags h . cmmToC platform + Stream.consume cmm_stream writeC {- ************************************************************************ @@ -151,17 +149,18 @@ outputC dflags filenm cmm_stream packages ************************************************************************ -} -outputAsm :: DynFlags -> Module -> ModLocation -> FilePath +outputAsm :: DynFlags + -> Module + -> ModLocation + -> FilePath -> Stream IO RawCmmGroup a -> IO a -outputAsm dflags this_mod location filenm cmm_stream - = do ncg_uniqs <- mkSplitUniqSupply 'n' - - debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm) - - {-# SCC "OutputAsm" #-} doOutput filenm $ - \h -> {-# SCC "NativeCodeGen" #-} - nativeCodeGen dflags this_mod location h ncg_uniqs cmm_stream +outputAsm dflags this_mod location filenm cmm_stream = do + ncg_uniqs <- mkSplitUniqSupply 'n' + debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm) + {-# SCC "OutputAsm" #-} doOutput filenm $ + \h -> {-# SCC "NativeCodeGen" #-} + nativeCodeGen dflags this_mod location h ncg_uniqs cmm_stream {- ************************************************************************ @@ -172,10 +171,10 @@ outputAsm dflags this_mod location filenm cmm_stream -} outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a -outputLlvm dflags filenm cmm_stream - = do {-# SCC "llvm_output" #-} doOutput filenm $ - \f -> {-# SCC "llvm_CodeGen" #-} - llvmCodeGen dflags f cmm_stream +outputLlvm dflags filenm cmm_stream = + {-# SCC "llvm_output" #-} doOutput filenm $ + \f -> {-# SCC "llvm_CodeGen" #-} + llvmCodeGen dflags f cmm_stream {- ************************************************************************ diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 143b1f5ccd..d12099f21b 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -575,7 +575,7 @@ tcRnModule' sum save_rn_syntax mod = do else do tcg_res' <- hscCheckSafeImports tcg_res safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res') - when safe $ do + when safe $ case wopt Opt_WarnSafe dflags of True | safeHaskell dflags == Sf_Safe -> return () @@ -801,8 +801,7 @@ hscIncrementalCompile always_do_basic_recompilation_check m_tc_result -- in one-shot mode, since we're not going to do -- any further typechecking. It's much more useful -- in make mode, since this HMI will go into the HPT. - details <- genModDetails hsc_env' iface - return details + genModDetails hsc_env' iface return (HscUpToDate iface details, dflags) -- We finished type checking. (mb_old_hash is the hash of -- the interface that existed on disk; it's possible we had @@ -1012,7 +1011,7 @@ hscCheckSafeImports tcg_env = do checkRULES dflags tcg_env' where - checkRULES dflags tcg_env' = do + checkRULES dflags tcg_env' = case safeLanguageOn dflags of True -> do -- XSafe: we nuke user written RULES @@ -1254,10 +1253,9 @@ hscCheckSafe' m l = do -- the 'lookupIfaceByModule' method will always fail when calling from GHCi -- as the compiler hasn't filled in the various module tables -- so we need to call 'getModuleInterface' to load from disk - iface' <- case iface of + case iface of Just _ -> return iface Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m) - return iface' -- | Check the list of packages are trusted. @@ -1924,9 +1922,8 @@ hscParseThingWithLocation source linenumber parser str loc = mkRealSrcLoc (fsLit source) linenumber 1 case unP parser (initParserState (initParserOpts dflags) buf loc) of - PFailed pst -> do + PFailed pst -> handleWarningsThrowErrors (getMessages pst) - POk pst thing -> do logWarningsReportErrors (getMessages pst) liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" @@ -1965,9 +1962,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr (icInteractiveModule (hsc_IC hsc_env)) prepd_expr {- link it -} - ; hval <- linkExpr hsc_env srcspan bcos - - ; return hval } + ; linkExpr hsc_env srcspan bcos } {- ********************************************************************** diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 5023eacdc7..19bef47e42 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -1168,7 +1168,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do -- The log_action callback that is used to synchronize messages from a -- worker thread. parLogAction :: LogQueue -> LogAction - parLogAction log_queue _dflags !reason !severity !srcSpan !msg = do + parLogAction log_queue _dflags !reason !severity !srcSpan !msg = writeLogQueue log_queue (Just (reason,severity,srcSpan,msg)) -- Print each message from the log_queue using the log_action from the diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 5428c83b99..2a2d9e294c 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -1,4 +1,8 @@ -{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -222,7 +226,7 @@ compileOne' m_tc_result mHscMessage in return $! HomeModInfo iface hmi_details mb_linkable (HscNotGeneratingCode _ _, _) -> panic "compileOne HscNotGeneratingCode" (_, NoBackend) -> panic "compileOne NoBackend" - (HscUpdateBoot iface hmi_details, Interpreter) -> do + (HscUpdateBoot iface hmi_details, Interpreter) -> return $! HomeModInfo iface hmi_details Nothing (HscUpdateBoot iface hmi_details, _) -> do touchObjectFile dflags object_filename @@ -773,7 +777,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) -- path, then rerun the pipeline for the dyn way let dflags = hsc_dflags hsc_env -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987) - when (not $ platformOS (targetPlatform dflags) == OSMinGW32) $ do + when (not $ platformOS (targetPlatform dflags) == OSMinGW32) $ when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do debugTraceMsg dflags 4 (text "Running the pipeline again for -dynamic-too") @@ -1094,31 +1098,30 @@ runPhase (RealPhase (Cpp sf)) input_fn dflags0 -- HsPp phase runPhase (RealPhase (HsPp sf)) input_fn dflags - = do - if not (gopt Opt_Pp dflags) then - -- no need to preprocess, just pass input file along - -- to the next phase of the pipeline. - return (RealPhase (Hsc sf), input_fn) - else do - PipeEnv{src_basename, src_suffix} <- getPipeEnv - let orig_fn = src_basename <.> src_suffix - output_fn <- phaseOutputFilename (Hsc sf) - liftIO $ GHC.SysTools.runPp dflags - ( [ GHC.SysTools.Option orig_fn - , GHC.SysTools.Option input_fn - , GHC.SysTools.FileOption "" output_fn - ] - ) - - -- re-read pragmas now that we've parsed the file (see #3674) - src_opts <- liftIO $ getOptionsFromFile dflags output_fn - (dflags1, unhandled_flags, warns) - <- liftIO $ parseDynamicFilePragma dflags src_opts - setDynFlags dflags1 - liftIO $ checkProcessArgsResult dflags1 unhandled_flags - liftIO $ handleFlagWarnings dflags1 warns - - return (RealPhase (Hsc sf), output_fn) + = if not (gopt Opt_Pp dflags) then + -- no need to preprocess, just pass input file along + -- to the next phase of the pipeline. + return (RealPhase (Hsc sf), input_fn) + else do + PipeEnv{src_basename, src_suffix} <- getPipeEnv + let orig_fn = src_basename <.> src_suffix + output_fn <- phaseOutputFilename (Hsc sf) + liftIO $ GHC.SysTools.runPp dflags + ( [ GHC.SysTools.Option orig_fn + , GHC.SysTools.Option input_fn + , GHC.SysTools.FileOption "" output_fn + ] + ) + + -- re-read pragmas now that we've parsed the file (see #3674) + src_opts <- liftIO $ getOptionsFromFile dflags output_fn + (dflags1, unhandled_flags, warns) + <- liftIO $ parseDynamicFilePragma dflags src_opts + setDynFlags dflags1 + liftIO $ checkProcessArgsResult dflags1 unhandled_flags + liftIO $ handleFlagWarnings dflags1 warns + + return (RealPhase (Hsc sf), output_fn) ----------------------------------------------------------------------------- -- Hsc phase @@ -1144,7 +1147,6 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 -- gather the imports and module name (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do - do buf <- hGetStringBuffer input_fn let imp_prelude = xopt LangExt.ImplicitPrelude dflags popts = initParserOpts dflags @@ -1478,8 +1480,8 @@ runPhase (RealPhase (As with_cpp)) input_fn dflags let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p) | p <- includePathsQuote cmdline_include_paths ] let runAssembler inputFilename outputFilename - = liftIO $ do - withAtomicRename outputFilename $ \temp_outputFilename -> do + = liftIO $ + withAtomicRename outputFilename $ \temp_outputFilename -> as_prog dflags (local_includes ++ global_includes @@ -2028,15 +2030,13 @@ maybeCreateManifest dflags exe_filename linkDynLibCheck :: DynFlags -> [String] -> [UnitId] -> IO () -linkDynLibCheck dflags o_files dep_units - = do - when (haveRtsOptsFlags dflags) $ do - putLogMsg dflags NoReason SevInfo noSrcSpan - $ withPprStyle defaultUserStyle - (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$ - text " Call hs_init_ghc() from your main() function to set these options.") - - linkDynLib dflags o_files dep_units +linkDynLibCheck dflags o_files dep_units = do + when (haveRtsOptsFlags dflags) $ + putLogMsg dflags NoReason SevInfo noSrcSpan + $ withPprStyle defaultUserStyle + (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$ + text " Call hs_init_ghc() from your main() function to set these options.") + linkDynLib dflags o_files dep_units -- | Linking a static lib will not really link anything. It will merely produce -- a static archive of all dependent static libraries. The resulting library @@ -2313,7 +2313,7 @@ joinObjectFiles dflags o_files output_fn = do writeFile filelist $ unlines o_files ld_r [GHC.SysTools.Option "-filelist", GHC.SysTools.FileOption "" filelist] - else do + else ld_r (map (GHC.SysTools.FileOption "") o_files) -- ----------------------------------------------------------------------------- diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 20fd137ea7..2000b9760b 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -1351,7 +1351,7 @@ defaultFatalMessager = hPutStrLn stderr -- jsonLogAction :: LogAction jsonLogAction dflags reason severity srcSpan msg - = do + = defaultLogActionHPutStrDoc dflags stdout (withPprStyle (PprCode CStyle) (doc $$ text "")) where @@ -3030,7 +3030,7 @@ package_flags_deps = [ (HasArg $ addPkgDbRef . PkgDbPath) "Use -package-db instead" , make_dep_flag defFlag "no-user-package-conf" (NoArg removeUserPkgDb) "Use -no-user-package-db instead" - , make_ord_flag defGhcFlag "package-name" (HasArg $ \name -> do + , make_ord_flag defGhcFlag "package-name" (HasArg $ \name -> upd (setUnitId name)) , make_ord_flag defGhcFlag "this-unit-id" (hasArg setUnitId) , make_ord_flag defFlag "package" (HasArg exposePackage) diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index db6508d581..1845f060ed 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -1595,8 +1595,8 @@ getLHsInstDeclClass_maybe :: LHsSigType (GhcPass p) -- Works on (LHsSigType GhcPs) getLHsInstDeclClass_maybe inst_ty = do { let head_ty = getLHsInstDeclHead inst_ty - ; cls <- hsTyGetAppHead_maybe head_ty - ; return cls } + ; hsTyGetAppHead_maybe head_ty + } {- Note [No nested foralls or contexts in instance types] diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index 9954c204dc..14de36906d 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -767,5 +767,3 @@ mkUnsafeCoercePrimPair _old_id old_expr id = mkExportedVanillaId unsafeCoercePrimName ty `setIdInfo` info ; return (id, old_expr) } - - where diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index 9b3bbdf0b0..cdc68599ba 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -163,7 +163,7 @@ mkModBreaks hsc_env mod count entries mkCCSArray :: HscEnv -> Module -> Int -> [MixEntry_] -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre)) -mkCCSArray hsc_env modul count entries = do +mkCCSArray hsc_env modul count entries = case hsc_interp hsc_env of Just interp | GHCi.interpreterProfiled interp -> do let module_str = moduleNameString (moduleName modul) @@ -198,7 +198,7 @@ writeMixEntries dflags mod count entries filename modTime <- getModificationUTCTime filename let entries' = [ (hpcPos, box) | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ] - when (entries' `lengthIsNot` count) $ do + when (entries' `lengthIsNot` count) $ panic "the number of .mix entries are inconsistent" let hashNo = mixHash filename modTime tabStop entries' mixCreate hpc_mod_dir mod_name @@ -268,12 +268,12 @@ addTickLHsBinds = mapBagM addTickLHsBind addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc) addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, - abs_exports = abs_exports })) = do - withEnv add_exports $ do - withEnv add_inlines $ do - binds' <- addTickLHsBinds binds - return $ L pos $ bind { abs_binds = binds' } - where + abs_exports = abs_exports })) = + withEnv add_exports $ + withEnv add_inlines $ do + binds' <- addTickLHsBinds binds + return $ L pos $ bind { abs_binds = binds' } + where -- in AbsBinds, the Id on each binding is not the actual top-level -- Id that we are defining, they are related by the abs_exports -- field of AbsBinds. So if we're doing TickExportedFunctions we need @@ -668,7 +668,7 @@ addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) -> TM (GRHSs GhcTc (LHsExpr GhcTc)) -addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = do +addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded @@ -711,12 +711,12 @@ addTickLStmts' isGuard lstmts res addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc) -> TM (Stmt GhcTc (LHsExpr GhcTc)) -addTickStmt _isGuard (LastStmt x e noret ret) = do +addTickStmt _isGuard (LastStmt x e noret ret) = liftM3 (LastStmt x) (addTickLHsExpr e) (pure noret) (addTickSyntaxExpr hpcSrcSpan ret) -addTickStmt _isGuard (BindStmt xbs pat e) = do +addTickStmt _isGuard (BindStmt xbs pat e) = liftM4 (\b f -> BindStmt $ XBindStmtTc { xbstc_bindOp = b , xbstc_boundResultType = xbstc_boundResultType xbs @@ -727,15 +727,15 @@ addTickStmt _isGuard (BindStmt xbs pat e) = do (mapM (addTickSyntaxExpr hpcSrcSpan) (xbstc_failOp xbs)) (addTickLPat pat) (addTickLHsExprRHS e) -addTickStmt isGuard (BodyStmt x e bind' guard') = do +addTickStmt isGuard (BodyStmt x e bind' guard') = liftM3 (BodyStmt x) (addTick isGuard e) (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard') -addTickStmt _isGuard (LetStmt x (L l binds)) = do +addTickStmt _isGuard (LetStmt x (L l binds)) = liftM (LetStmt x . L l) (addTickHsLocalBinds binds) -addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do +addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = liftM3 (ParStmt x) (mapM (addTickStmtAndBinders isGuard) pairs) (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr)) @@ -920,7 +920,7 @@ addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) = return $ match { m_grhss = gRHSs' } addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)) -addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = do +addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (liftL addTickCmdGRHS) guarded @@ -953,21 +953,21 @@ addTickLCmdStmts' lstmts res binders = collectLStmtsBinders lstmts addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc)) -addTickCmdStmt (BindStmt x pat c) = do +addTickCmdStmt (BindStmt x pat c) = liftM2 (BindStmt x) (addTickLPat pat) (addTickLHsCmd c) -addTickCmdStmt (LastStmt x c noret ret) = do +addTickCmdStmt (LastStmt x c noret ret) = liftM3 (LastStmt x) (addTickLHsCmd c) (pure noret) (addTickSyntaxExpr hpcSrcSpan ret) -addTickCmdStmt (BodyStmt x c bind' guard') = do +addTickCmdStmt (BodyStmt x c bind' guard') = liftM3 (BodyStmt x) (addTickLHsCmd c) (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard') -addTickCmdStmt (LetStmt x (L l binds)) = do +addTickCmdStmt (LetStmt x (L l binds)) = liftM (LetStmt x . L l) (addTickHsLocalBinds binds) addTickCmdStmt stmt@(RecStmt {}) diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 1fa2c5f98b..c1479d7c9a 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -239,16 +239,18 @@ dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) ************************************************************************ -} -dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr -dsLExpr (L loc e) - = putSrcSpanDs loc $ - do { core_expr <- dsExpr e - -- uncomment this check to test the hsExprType function in GHC.Tc.Utils.Zonk - -- ; MASSERT2( exprType core_expr `eqType` hsExprType e - -- , ppr e <+> dcolon <+> ppr (hsExprType e) $$ - -- ppr core_expr <+> dcolon <+> ppr (exprType core_expr) ) - ; return core_expr } +-- | Replace the body of the fucntion with this block to test the hsExprType +-- function in GHC.Tc.Utils.Zonk: +-- putSrcSpanDs loc $ do +-- { core_expr <- dsExpr e +-- ; MASSERT2( exprType core_expr `eqType` hsExprType e +-- , ppr e <+> dcolon <+> ppr (hsExprType e) $$ +-- ppr core_expr <+> dcolon <+> ppr (exprType core_expr) ) +-- ; return core_expr } +dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr +dsLExpr (L loc e) = + putSrcSpanDs loc $ dsExpr e -- | Variant of 'dsLExpr' that ensures that the result is not levity -- polymorphic. This should be used when the resulting expression will @@ -416,7 +418,7 @@ dsExpr e@(SectionL _ expr op) = do x_core <- dsLExpr expr case splitFunTys (exprType core_op) of -- Binary operator section - (x_ty:y_ty:_, _) -> do + (x_ty:y_ty:_, _) -> dsWhenNoErrs (newSysLocalsDsNoLP [x_ty, y_ty]) (\[x_id, y_id] -> @@ -425,7 +427,7 @@ dsExpr e@(SectionL _ expr op) = do core_op [Var x_id, Var y_id])) -- Postfix operator section - (_:_, _) -> do + (_:_, _) -> return $ mkCoreAppDs (text "sectionl" <+> ppr e) core_op x_core _ -> pprPanic "dsExpr(SectionL)" (ppr e) @@ -462,11 +464,11 @@ dsExpr (ExplicitTuple _ tup_args boxity) -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make dsExpr (ExplicitSum types alt arity expr) - = do { dsWhenNoErrs (dsLExprNoLP expr) - (\core_expr -> mkCoreConApps (sumDataCon alt arity) - (map (Type . getRuntimeRep) types ++ - map Type types ++ - [core_expr]) ) } + = dsWhenNoErrs (dsLExprNoLP expr) + (\core_expr -> mkCoreConApps (sumDataCon alt arity) + (map (Type . getRuntimeRep) types ++ + map Type types ++ + [core_expr]) ) dsExpr (HsPragE _ prag expr) = ds_prag_expr prag expr @@ -1189,12 +1191,12 @@ warnDiscardedDoBindings rhs rhs_ty -- Warn about discarding m a things in 'monadic' binding of the same type, -- but only if we didn't already warn due to Opt_WarnUnusedDoBind when warn_wrong $ - do { case tcSplitAppTy_maybe norm_elt_ty of - Just (elt_m_ty, _) - | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty - -> warnDs (Reason Opt_WarnWrongDoBind) - (badMonadBind rhs elt_ty) - _ -> return () } } } + case tcSplitAppTy_maybe norm_elt_ty of + Just (elt_m_ty, _) + | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty + -> warnDs (Reason Opt_WarnWrongDoBind) + (badMonadBind rhs elt_ty) + _ -> return () } } | otherwise -- RHS does have type of form (m ty), which is weird = return () -- but at least this warning is irrelevant diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index 6a9fa35111..12c9a49278 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -27,7 +27,7 @@ import GHC.Platform import {-#SOURCE#-} GHC.HsToCore.Expr (dsLExpr, dsSyntaxExpr) -import GHC.Types.Basic ( Origin(..) ) +import GHC.Types.Basic ( Origin(..), isGenerated, Boxity(..) ) import GHC.Types.SourceText import GHC.Driver.Session import GHC.Hs @@ -61,7 +61,6 @@ import GHC.Utils.Misc import GHC.Types.Name import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Types.Basic ( isGenerated, Boxity(..) ) import GHC.Data.FastString import GHC.Types.Unique import GHC.Types.Unique.DFM @@ -409,7 +408,7 @@ tidyEqnInfo _ (EqnInfo { eqn_pats = [] }) tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig }) = do { (wrap, pat') <- tidy1 v orig pat - ; return (wrap, eqn { eqn_pats = do pat' : pats }) } + ; return (wrap, eqn { eqn_pats = pat' : pats }) } tidy1 :: Id -- The Id being scrutinised -> Origin -- Was this a pattern the user wrote? diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs index 70acb36724..7cf9f2e483 100644 --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -105,7 +105,7 @@ dsLit l = do HsString _ str -> mkStringExprFS str HsInteger _ i _ -> return (mkIntegerExpr i) HsInt _ i -> return (mkIntExpr platform (il_value i)) - HsRat _ (FL _ _ val) ty -> do + HsRat _ (FL _ _ val) ty -> return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom]) where num = mkIntegerExpr (numerator val) @@ -223,7 +223,7 @@ warnAboutOverflowedLiterals dflags lit checkPositive :: Integer -> Name -> DsM () checkPositive i tc - = when (i < 0) $ do + = when (i < 0) $ warnDs (Reason Opt_WarnOverflowedLiterals) (vcat [ text "Literal" <+> integer i <+> text "is negative but" <+> ppr tc @@ -232,7 +232,7 @@ warnAboutOverflowedLiterals dflags lit check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM () check i tc _proxy - = when (i < minB || i > maxB) $ do + = when (i < minB || i > maxB) $ warnDs (Reason Opt_WarnOverflowedLiterals) (vcat [ text "Literal" <+> integer i <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range") diff --git a/compiler/GHC/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs index e409c1fcae..7af0d4605e 100644 --- a/compiler/GHC/HsToCore/Pmc.hs +++ b/compiler/GHC/HsToCore/Pmc.hs @@ -267,7 +267,7 @@ testRedSets :: RedSets -> DsM (Bool, Bool, OrdList SrcInfo) testRedSets RedSets { rs_cov = cov, rs_div = div, rs_bangs = bangs } = do is_covered <- isInhabited cov may_diverge <- isInhabited div - red_bangs <- flip mapMaybeM (fromOL bangs) $ \(nablas, bang) -> do + red_bangs <- flip mapMaybeM (fromOL bangs) $ \(nablas, bang) -> isInhabited nablas >>= \case True -> pure Nothing False -> pure (Just bang) @@ -351,14 +351,14 @@ reportWarnings dflags ctx@(DsMatchContext kind loc) vars when (approx && (exists_u || exists_i)) $ putSrcSpanDs loc (warnDs NoReason approx_msg) - when exists_b $ forM_ redundant_bangs $ \(SrcInfo (L l q)) -> do + when exists_b $ forM_ redundant_bangs $ \(SrcInfo (L l q)) -> putSrcSpanDs l (warnDs (Reason Opt_WarnRedundantBangPatterns) (pprEqn q "has redundant bang")) - when exists_r $ forM_ redundant_rhss $ \(SrcInfo (L l q)) -> do + when exists_r $ forM_ redundant_rhss $ \(SrcInfo (L l q)) -> putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) (pprEqn q "is redundant")) - when exists_i $ forM_ inaccessible_rhss $ \(SrcInfo (L l q)) -> do + when exists_i $ forM_ inaccessible_rhss $ \(SrcInfo (L l q)) -> putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) (pprEqn q "has inaccessible right hand side")) diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs index f08774a647..98b23dab25 100644 --- a/compiler/GHC/HsToCore/Pmc/Desugar.hs +++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs @@ -39,12 +39,11 @@ import GHC.Core.Coercion import GHC.Tc.Types.Evidence (HsWrapper(..), isIdHsWrapper) import {-# SOURCE #-} GHC.HsToCore.Expr (dsExpr, dsLExpr, dsSyntaxExpr) import {-# SOURCE #-} GHC.HsToCore.Binds (dsHsWrapper) -import GHC.HsToCore.Utils (selectMatchVar) +import GHC.HsToCore.Utils (isTrueLHsExpr, selectMatchVar) import GHC.HsToCore.Match.Literal (dsLit, dsOverLit) import GHC.HsToCore.Monad import GHC.Core.TyCo.Rep import GHC.Core.Type -import GHC.HsToCore.Utils (isTrueLHsExpr) import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.Monad (concatMapM) @@ -188,7 +187,7 @@ desugarPat x pat = case pat of , cpt_tvs = ex_tvs , cpt_dicts = dicts } - } -> do + } -> desugarConPatOut x con arg_tys ex_tvs dicts ps NPat ty (L _ olit) mb_neg _ -> do @@ -363,7 +362,7 @@ desugarGuard guard = case guard of -- recursion, pattern bindings etc. -- See Note [Long-distance information for HsLocalBinds]. desugarLocalBinds :: LHsLocalBinds GhcTc -> DsM [PmGrd] -desugarLocalBinds (L _ (HsValBinds _ (XValBindsLR (NValBinds binds _)))) = do +desugarLocalBinds (L _ (HsValBinds _ (XValBindsLR (NValBinds binds _)))) = concatMapM (concatMapM go . bagToList) (map snd binds) where go :: LHsBind GhcTc -> DsM [PmGrd] diff --git a/compiler/GHC/HsToCore/Pmc/Solver.hs b/compiler/GHC/HsToCore/Pmc/Solver.hs index 235ed08492..326b532325 100644 --- a/compiler/GHC/HsToCore/Pmc/Solver.hs +++ b/compiler/GHC/HsToCore/Pmc/Solver.hs @@ -388,7 +388,7 @@ pmIsClosedType ty -- efficient. normaliseSourceTypeWHNF :: TyState -> Type -> DsM Type normaliseSourceTypeWHNF _ ty | isSourceTypeInWHNF ty = pure ty -normaliseSourceTypeWHNF ty_st ty = do +normaliseSourceTypeWHNF ty_st ty = pmTopNormaliseType ty_st ty >>= \case NoChange ty -> pure ty NormalisedByConstraints ty -> pure ty @@ -1223,7 +1223,7 @@ inhabitationTest fuel old_ty_st nabla@MkNabla{ nabla_tm_st = ts } = do where nabla_not_dirty = nabla{ nabla_tm_st = ts{ts_dirty=emptyDVarSet} } test_one :: VarInfo -> MaybeT DsM VarInfo - test_one vi = do + test_one vi = lift (varNeedsTesting old_ty_st nabla vi) >>= \case True -> do -- tracPm "test_one" (ppr vi) diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index b22d45d182..fef9d4c094 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -593,9 +593,9 @@ repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn -> MetaM (Core (Maybe (M TH.Kind))) repFamilyResultSigToMaybeKind (NoSig _) = - do { coreNothingM kindTyConName } + coreNothingM kindTyConName repFamilyResultSigToMaybeKind (KindSig _ ki) = - do { coreJustM kindTyConName =<< repLTy ki } + coreJustM kindTyConName =<< repLTy ki repFamilyResultSigToMaybeKind TyVarSig{} = panic "repFamilyResultSigToMaybeKind: unexpected TyVarSig" @@ -603,7 +603,7 @@ repFamilyResultSigToMaybeKind TyVarSig{} = repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) -> MetaM (Core (Maybe TH.InjectivityAnn)) repInjectivityAnn Nothing = - do { coreNothing injAnnTyConName } + coreNothing injAnnTyConName repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) = do { lhs' <- lookupBinder (unLoc lhs) ; rhs1 <- mapM (lookupBinder . unLoc) rhs @@ -884,14 +884,13 @@ repC (L _ (ConDeclH98 { con_name = con , con_ex_tvs = con_tvs , con_mb_cxt = mcxt , con_args = args })) - = do { addHsTyVarBinds con_tvs $ \ ex_bndrs -> + = addHsTyVarBinds con_tvs $ \ ex_bndrs -> do { c' <- repH98DataCon con args ; ctxt' <- repMbContext mcxt ; if not is_existential && isNothing mcxt then return c' else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } - } repC (L _ (ConDeclGADT { con_g_ext = imp_tvs , con_names = cons diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs index 84ee0af60b..69aee26586 100644 --- a/compiler/GHC/Iface/Ext/Binary.hs +++ b/compiler/GHC/Iface/Ext/Binary.hs @@ -222,9 +222,7 @@ readHieFileHeader file bh0 = do readHieFileContents :: BinHandle -> NameCacheUpdater -> IO HieFile readHieFileContents bh0 ncu = do - - dict <- get_dictionary bh0 - + dict <- get_dictionary bh0 -- read the symbol table so we are capable of reading the actual data bh1 <- do let bh1 = setUserData bh0 $ newReadState (error "getSymtabName") @@ -236,8 +234,7 @@ readHieFileContents bh0 ncu = do return bh1' -- load the actual data - hiefile <- get bh1 - return hiefile + get bh1 where get_dictionary bin_handle = do dict_p <- get bin_handle diff --git a/compiler/GHC/Iface/Ext/Fields.hs b/compiler/GHC/Iface/Ext/Fields.hs index 1cc1e94012..37322303d8 100644 --- a/compiler/GHC/Iface/Ext/Fields.hs +++ b/compiler/GHC/Iface/Ext/Fields.hs @@ -49,7 +49,7 @@ instance Binary ExtensibleFields where n <- get bh :: IO Int -- Get the names and field pointers: - header_entries <- replicateM n $ do + header_entries <- replicateM n $ (,) <$> get bh <*> get bh -- Seek to and get each field's payload: diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs index 9245a11f7b..5166ddc6b2 100644 --- a/compiler/GHC/Iface/Ext/Utils.hs +++ b/compiler/GHC/Iface/Ext/Utils.hs @@ -194,9 +194,8 @@ compressTypes compressTypes asts = (a, arr) where (a, (HTS _ m i)) = flip runState initialHTS $ - for asts $ \typ -> do - i <- getTypeIndex typ - return i + for asts $ \typ -> + getTypeIndex typ arr = A.array (0,i-1) (IM.toList m) recoverFullType :: TypeIndex -> A.Array TypeIndex HieTypeFlat -> HieTypeFix diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 16ca152edc..55c3b0ce2a 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -471,7 +471,7 @@ loadInterface doc_str mod from let loc_doc = text loc in - initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ do + initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ dontLeakTheHPT $ do diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index c810911509..a21b6dac07 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -283,7 +283,7 @@ checkPlugins hsc iface = liftIO $ do pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr fingerprintPlugins :: HscEnv -> IO Fingerprint -fingerprintPlugins hsc_env = do +fingerprintPlugins hsc_env = fingerprintPlugins' $ plugins (hsc_dflags hsc_env) fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint @@ -448,7 +448,7 @@ checkMergedSignatures mod_summary iface = do -- Returns (RecompBecause <textual reason>) if recompilation is required. checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired checkDependencies hsc_env summary iface - = do + = checkList $ [ checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary)) , do @@ -618,8 +618,7 @@ checkModUsage this_pkg UsageHomeModule{ recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash if not (recompileRequired recompile) then return UpToDate - else do - + else -- CHECK EXPORT LIST checkMaybeHash reason maybe_old_export_hash new_export_hash (text " Export list changed") $ do @@ -874,7 +873,7 @@ addFingerprints hsc_env iface0 extend_hash_env :: OccEnv (OccName,Fingerprint) -> (Fingerprint,IfaceDecl) -> IO (OccEnv (OccName,Fingerprint)) - extend_hash_env env0 (hash,d) = do + extend_hash_env env0 (hash,d) = return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0 (ifaceDeclFingerprints hash d)) @@ -1379,14 +1378,13 @@ mkHashFun hsc_env eps name MASSERT2( isExternalName name, ppr name ) iface <- case lookupIfaceByModule hpt pit mod of Just iface -> return iface - Nothing -> do + Nothing -> -- This can occur when we're writing out ifaces for -- requirements; we didn't do any /real/ typechecking -- so there's no guarantee everything is loaded. -- Kind of a heinous hack. - iface <- initIfaceLoad hsc_env . withException - $ loadInterface (text "lookupVers2") mod ImportBySystem - return iface + initIfaceLoad hsc_env . withException + $ loadInterface (text "lookupVers2") mod ImportBySystem return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse` pprPanic "lookupVers1" (ppr mod <+> ppr occ)) diff --git a/compiler/GHC/Iface/Recomp/Binary.hs b/compiler/GHC/Iface/Recomp/Binary.hs index 8a72a1dcb3..083ad431af 100644 --- a/compiler/GHC/Iface/Recomp/Binary.hs +++ b/compiler/GHC/Iface/Recomp/Binary.hs @@ -35,8 +35,7 @@ computeFingerprint :: (Binary a) computeFingerprint put_nonbinding_name a = do bh <- fmap set_user_data $ openBinMem (3*1024) -- just less than a block put_ bh a - fp <- fingerprintBinMem bh - return fp + fingerprintBinMem bh where set_user_data bh = setUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index 749914821a..4bd9867617 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -103,7 +103,7 @@ failWithRn doc = do -- when loading an interface to merge it into a requirement.) rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape -> ModIface -> IO (Either ErrorMessages ModIface) -rnModIface hsc_env insts nsubst iface = do +rnModIface hsc_env insts nsubst iface = initRnIface hsc_env iface insts nsubst $ do mod <- rnModule (mi_module iface) sig_of <- case mi_sig_of iface of diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs index e6fc3a8bc0..27d64c88e5 100644 --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -2140,10 +2140,10 @@ instance Binary IfaceBang where get bh = do h <- getByte bh case h of - 0 -> do return IfNoBang - 1 -> do return IfStrict - 2 -> do return IfUnpack - _ -> do { a <- get bh; return (IfUnpackCo a) } + 0 -> return IfNoBang + 1 -> return IfStrict + 2 -> return IfUnpack + _ -> IfUnpackCo <$> get bh instance Binary IfaceSrcBang where put_ bh (IfSrcBang a1 a2) = diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs index 57889754fe..e87998dd37 100644 --- a/compiler/GHC/Iface/Type.hs +++ b/compiler/GHC/Iface/Type.hs @@ -858,15 +858,15 @@ instance Binary IfaceBndr where return (IfaceTvBndr ab) instance Binary IfaceOneShot where - put_ bh IfaceNoOneShot = do + put_ bh IfaceNoOneShot = putByte bh 0 - put_ bh IfaceOneShot = do + put_ bh IfaceOneShot = putByte bh 1 get bh = do h <- getByte bh case h of - 0 -> do return IfaceNoOneShot - _ -> do return IfaceOneShot + 0 -> return IfaceNoOneShot + _ -> return IfaceOneShot -- ----------------------------- Printing IfaceType ------------------------------------ @@ -1905,7 +1905,7 @@ instance Binary IfaceType where return (IfaceLitTy n) instance Binary IfaceMCoercion where - put_ bh IfaceMRefl = do + put_ bh IfaceMRefl = putByte bh 1 put_ bh (IfaceMCo co) = do putByte bh 2 diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index b382165834..6a4861c727 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -400,7 +400,7 @@ typecheckIfacesForMerging mod ifaces tc_env_var = -- OK, now typecheck each ModIface using this environment details <- forM ifaces $ \iface -> do -- See Note [Resolving never-exported Names] in GHC.IfaceToCore - type_env <- fixM $ \type_env -> do + type_env <- fixM $ \type_env -> setImplicitEnvM type_env $ do decls <- tcIfaceDecls ignore_prags (mi_decls iface) return (mkNameEnv decls) @@ -440,7 +440,7 @@ typecheckIfaceForInstantiate nsubst iface = (mi_boot iface) nsubst $ do ignore_prags <- goptM Opt_IgnoreInterfacePragmas -- See Note [Resolving never-exported Names] in GHC.IfaceToCore - type_env <- fixM $ \type_env -> do + type_env <- fixM $ \type_env -> setImplicitEnvM type_env $ do decls <- tcIfaceDecls ignore_prags (mi_decls iface) return (mkNameEnv decls) @@ -1256,10 +1256,9 @@ tcIfaceAnnotation (IfaceAnnotation target serialized) = do } tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name) -tcIfaceAnnTarget (NamedTarget occ) = do - name <- lookupIfaceTop occ - return $ NamedTarget name -tcIfaceAnnTarget (ModuleTarget mod) = do +tcIfaceAnnTarget (NamedTarget occ) = + NamedTarget <$> lookupIfaceTop occ +tcIfaceAnnTarget (ModuleTarget mod) = return $ ModuleTarget mod {- diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs index d9f2964638..fdf854ad8e 100644 --- a/compiler/GHC/Parser/Header.hs +++ b/compiler/GHC/Parser/Header.hs @@ -189,7 +189,7 @@ lazyGetToks popts filename handle = do loc = mkRealSrcLoc (mkFastString filename) 1 1 lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token] - lazyLexBuf handle state eof size = do + lazyLexBuf handle state eof size = case unP (lexer False return) state of POk state' t -> do -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ()) diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 8e85c9493e..84aa3e09bc 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -810,7 +810,7 @@ mkRuleTyVarBndrs = fmap (fmap cvt_one) -- See note [Parsing explicit foralls in Rules] in Parser.y checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P () checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) - where check (L loc (Unqual occ)) = do + where check (L loc (Unqual occ)) = -- TODO: don't use string here, OccName has a Unique/FastString when ((occNameString occ ==) `any` ["forall","family","role"]) (addFatalError $ Error (ErrParseErrorOnInput occ) [] loc) @@ -878,8 +878,7 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV () (checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd) where checkExpr :: LHsExpr GhcPs -> PV () - checkExpr expr = do - case unLoc expr of + checkExpr expr = case unLoc expr of HsDo _ (DoExpr m) _ -> check (ErrDoInFunAppExpr m) expr HsDo _ (MDoExpr m) _ -> check (ErrMDoInFunAppExpr m) expr HsLam {} -> check ErrLambdaInFunAppExpr expr @@ -1458,7 +1457,7 @@ instance DisambECP (HsExpr GhcPs) where mkHsLetPV l bs c = return $ L l (HsLet noExtField bs c) type InfixOp (HsExpr GhcPs) = HsExpr GhcPs superInfixOp m = m - mkHsOpAppPV l e1 op e2 = do + mkHsOpAppPV l e1 op e2 = return $ L l $ OpApp noExtField e1 op e2 mkHsCasePV l e mg = return $ L l (HsCase noExtField e mg) mkHsLamCasePV l mg = return $ L l (HsLamCase noExtField mg) diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs index 9215ef26fc..953d3c2c9b 100644 --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -885,7 +885,7 @@ rnMethodBindLHS :: Bool -> Name -> LHsBindsLR GhcRn GhcPs -> RnM (LHsBindsLR GhcRn GhcPs) rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest - = setSrcSpan loc $ do + = setSrcSpan loc $ do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name -- We use the selector name as the binder ; let bind' = bind { fun_id = sel_name, fun_ext = noExtField } @@ -1034,7 +1034,7 @@ renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty) new_mty <- traverse lookupLocatedOccRn mty this_mod <- fmap tcg_mod getGblEnv - unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $ do + unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $ -- Why 'any'? See Note [Orphan COMPLETE pragmas] addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError @@ -1173,20 +1173,20 @@ rnMatch :: Outputable (body GhcPs) => HsMatchContext GhcRn -> RnM (LMatch GhcRn (Located (body GhcRn)), FreeVars) rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody) +-- Note that there are no local fixity decls for matches rnMatch' :: Outputable (body GhcPs) => HsMatchContext GhcRn -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> Match GhcPs (Located (body GhcPs)) -> RnM (Match GhcRn (Located (body GhcRn)), FreeVars) -rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss }) - = do { -- Note that there are no local fixity decls for matches - ; rnPats ctxt pats $ \ pats' -> do +rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss }) = + rnPats ctxt pats $ \ pats' -> do { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss ; let mf' = case (ctxt, mf) of - (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ }) - -> mf { mc_fun = L lf funid } - _ -> ctxt + (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ }) -> + mf { mc_fun = L lf funid } + _ -> ctxt ; return (Match { m_ext = noExtField, m_ctxt = mf', m_pats = pats' - , m_grhss = grhss'}, grhss_fvs ) }} + , m_grhss = grhss'}, grhss_fvs ) } emptyCaseErr :: HsMatchContext GhcRn -> SDoc emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt) diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index 14218b01f6..b38b4679b1 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -108,16 +108,16 @@ finishHsVar (L l name) ; return (HsVar noExtField (L l name), unitFV name) } rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars) -rnUnboundVar v - = do { if isUnqual v - then -- Treat this as a "hole" - -- Do not fail right now; instead, return HsUnboundVar - -- and let the type checker report the error - return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs) +rnUnboundVar v = + if isUnqual v + then -- Treat this as a "hole" + -- Do not fail right now; instead, return HsUnboundVar + -- and let the type checker report the error + return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs) - else -- Fail immediately (qualified name) - do { n <- reportUnboundName v - ; return (HsVar noExtField (noLoc n), emptyFVs) } } + else -- Fail immediately (qualified name) + do { n <- reportUnboundName v + ; return (HsVar noExtField (noLoc n), emptyFVs) } rnExpr (HsVar _ (L l v)) = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields @@ -847,10 +847,10 @@ rnStmt ctxt rnBody (L loc (BindStmt _ pat body)) thing_inside -- but it does not matter because the names are unique rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside - = do { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do + = rnLocalBindsAndThen binds $ \binds' bind_fvs -> do { (thing, fvs) <- thing_inside (collectLocalBinders binds') ; return ( ([(L loc (LetStmt noExtField (L l binds')), bind_fvs)], thing) - , fvs) } } + , fvs) } rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside = do { (return_op, fvs1) <- lookupQualifiedDoStmtName ctxt returnMName diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index f815cd5c4a..d535f008ae 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -449,8 +449,8 @@ checkCanonicalInstances cls poly_ty mbinds = do -- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@). -- checkCanonicalMonadInstances refURL - | cls == applicativeClassName = do - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do + | cls == applicativeClassName = + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ case mbind of FunBind { fun_id = L _ name , fun_matches = mg } @@ -464,8 +464,8 @@ checkCanonicalInstances cls poly_ty mbinds = do _ -> return () - | cls == monadClassName = do - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do + | cls == monadClassName = + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ case mbind of FunBind { fun_id = L _ name , fun_matches = mg } @@ -495,8 +495,8 @@ checkCanonicalInstances cls poly_ty mbinds = do -- * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@). -- checkCanonicalMonoidInstances refURL - | cls == semigroupClassName = do - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do + | cls == semigroupClassName = + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ case mbind of FunBind { fun_id = L _ name , fun_matches = mg } @@ -506,8 +506,8 @@ checkCanonicalInstances cls poly_ty mbinds = do _ -> return () - | cls == monoidClassName = do - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do + | cls == monoidClassName = + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ case mbind of FunBind { fun_id = L _ name , fun_matches = mg } @@ -531,7 +531,7 @@ checkCanonicalInstances cls poly_ty mbinds = do isAliasMG _ = Nothing -- got "lhs = rhs" but expected something different - addWarnNonCanonicalMethod1 refURL flag lhs rhs = do + addWarnNonCanonicalMethod1 refURL flag lhs rhs = addWarn (Reason flag) $ vcat [ text "Noncanonical" <+> quotes (text (lhs ++ " = " ++ rhs)) <+> @@ -545,7 +545,7 @@ checkCanonicalInstances cls poly_ty mbinds = do ] -- expected "lhs = rhs" but got something else - addWarnNonCanonicalMethod2 refURL flag lhs rhs = do + addWarnNonCanonicalMethod2 refURL flag lhs rhs = addWarn (Reason flag) $ vcat [ text "Noncanonical" <+> quotes (text lhs) <+> diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index ac8117e4a1..cde4fe6d4a 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -1025,7 +1025,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) -- different parents). See Note [Dealing with imports] lookup_ie :: IE GhcPs -> IELookupM ([(IE GhcRn, AvailInfo)], [IELookupWarning]) - lookup_ie ie = handle_bad_import $ do + lookup_ie ie = handle_bad_import $ case ie of IEVar _ (L l n) -> do (name, avail, _) <- lookup_name ie $ ieWrappedName n diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs index c18074097d..48378ba670 100644 --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -37,17 +37,16 @@ import Control.Monad ( unless, when ) import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) -import GHC.Tc.Utils.Env ( checkWellStaged ) -import GHC.Builtin.Names.TH ( liftName ) +import GHC.Tc.Utils.Env ( checkWellStaged, tcMetaTy ) import GHC.Driver.Session import GHC.Data.FastString import GHC.Utils.Error ( dumpIfSet_dyn_printer, DumpFormat (..) ) import GHC.Utils.Panic -import GHC.Tc.Utils.Env ( tcMetaTy ) import GHC.Driver.Hooks -import GHC.Builtin.Names.TH ( quoteExpName, quotePatName, quoteDecName, quoteTypeName - , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, ) +import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName, liftName + , patQTyConName, quoteDecName, quoteExpName + , quotePatName, quoteTypeName, typeQTyConName) import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcCheckPolyExpr ) import {-# SOURCE #-} GHC.Tc.Gen.Splice diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index a29a8b6602..68d453a68f 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -366,8 +366,8 @@ checkUnusedRecordWildcard :: SrcSpan -> FreeVars -> Maybe [Name] -> RnM () -checkUnusedRecordWildcard _ _ Nothing = return () -checkUnusedRecordWildcard loc _ (Just []) = do +checkUnusedRecordWildcard _ _ Nothing = return () +checkUnusedRecordWildcard loc _ (Just []) = -- Add a new warning if the .. pattern binds no variables setSrcSpan loc $ warnRedundantRecordWildcard checkUnusedRecordWildcard loc fvs (Just dotdot_names) = diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index 337cd24d80..db0c9928ce 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -436,7 +438,7 @@ resumeExec canLogSpan step , resumeBindings = bindings, resumeFinalIds = final_ids , resumeApStack = apStack, resumeBreakInfo = mb_brkpt , resumeSpan = span - , resumeHistory = hist } -> do + , resumeHistory = hist } -> withVirtualCWD $ do status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv let prevHistoryLst = fromListBL 50 hist @@ -630,8 +632,7 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do [id | id <- tmp_ids , not $ noSkolems id , (occNameFS.nameOccName.idName) id /= result_fs] - hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds) - return hsc_env' + foldM improveTypes hsc_env (map idName incompletelyTypedIds) where noSkolems = noFreeVarsOfType . idType improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do @@ -870,7 +871,7 @@ getInfo allInfo name -- | Returns all names in scope in the current interactive context getNamesInScope :: GhcMonad m => m [Name] -getNamesInScope = withSession $ \hsc_env -> do +getNamesInScope = withSession $ \hsc_env -> return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) -- | Returns all 'RdrName's in scope in the current interactive @@ -917,7 +918,7 @@ isImport pflags stmt = -- | Returns @True@ if passed string is a declaration but __/not a splice/__. isDecl :: ParserOpts -> String -> Bool -isDecl pflags stmt = do +isDecl pflags stmt = case parseThing Parser.parseDeclaration pflags stmt of Lexer.POk _ thing -> case unLoc thing of @@ -1011,7 +1012,7 @@ exprType mode expr = withSession $ \hsc_env -> do -- | Get the kind of a type typeKind :: GhcMonad m => Bool -> String -> m (Type, Kind) -typeKind normalise str = withSession $ \hsc_env -> do +typeKind normalise str = withSession $ \hsc_env -> liftIO $ hscKcType hsc_env normalise str -- ---------------------------------------------------------------------------- @@ -1062,8 +1063,8 @@ typeKind normalise str = withSession $ \hsc_env -> do -- Find all instances that match a provided type getInstancesForType :: GhcMonad m => Type -> m [ClsInst] -getInstancesForType ty = withSession $ \hsc_env -> do - liftIO $ runInteractiveHsc hsc_env $ do +getInstancesForType ty = withSession $ \hsc_env -> + liftIO $ runInteractiveHsc hsc_env $ ioMsgMaybe $ runTcInteractive hsc_env $ do -- Bring class and instances from unqualified modules into scope, this fixes #16793. loadUnqualIfaces hsc_env (hsc_IC hsc_env) @@ -1204,7 +1205,7 @@ checkForExistence clsInst mb_inst_tys = do -- | Parse an expression, the parsed expression can be further processed and -- passed to compileParsedExpr. parseExpr :: GhcMonad m => String -> m (LHsExpr GhcPs) -parseExpr expr = withSession $ \hsc_env -> do +parseExpr expr = withSession $ \hsc_env -> liftIO $ runInteractiveHsc hsc_env $ hscParseExpr expr -- | Compile an expression, run it, and deliver the resulting HValue. diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs index 34c55760ac..8de6a0d39d 100644 --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -1019,7 +1019,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do traceTR (text "Constr1" <+> ppr dcname) (mb_dc, _) <- tryTc (tcLookupDataCon dcname) case mb_dc of - Nothing-> do + Nothing-> forM pArgs $ \x -> do tv <- newVar liftedTypeKind return (tv, x) diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs index 6cd00efdd2..5213b02a4f 100644 --- a/compiler/GHC/Runtime/Interpreter.hs +++ b/compiler/GHC/Runtime/Interpreter.hs @@ -191,7 +191,7 @@ iservCmd hsc_env msg = withInterp hsc_env $ \case InternalInterp -> run msg -- Just run it directly #endif (ExternalInterp c i) -> withIServ_ c i $ \iserv -> - uninterruptibleMask_ $ do -- Note [uninterruptibleMask_] + uninterruptibleMask_ $ -- Note [uninterruptibleMask_] iservCall iserv msg @@ -223,7 +223,7 @@ hscInterp hsc_env = case hsc_interp hsc_env of withIServ :: (ExceptionMonad m) => IServConfig -> IServ -> (IServInstance -> m (IServInstance, a)) -> m a -withIServ conf (IServ mIServState) action = do +withIServ conf (IServ mIServState) action = MC.mask $ \restore -> do state <- liftIO $ takeMVar mIServState @@ -286,7 +286,7 @@ resumeStmt hsc_env step resume_ctxt = do handleEvalStatus hsc_env status abandonStmt :: HscEnv -> ForeignRef (ResumeContext [HValueRef]) -> IO () -abandonStmt hsc_env resume_ctxt = do +abandonStmt hsc_env resume_ctxt = withForeignRef resume_ctxt $ \rhv -> iservCmd hsc_env (AbandonStmt rhv) @@ -300,24 +300,24 @@ handleEvalStatus hsc_env status = EvalComplete alloc <$> addFinalizer res where addFinalizer (EvalException e) = return (EvalException e) - addFinalizer (EvalSuccess rs) = do + addFinalizer (EvalSuccess rs) = EvalSuccess <$> mapM (mkFinalizedHValue hsc_env) rs -- | Execute an action of type @IO ()@ evalIO :: HscEnv -> ForeignHValue -> IO () -evalIO hsc_env fhv = do +evalIO hsc_env fhv = liftIO $ withForeignRef fhv $ \fhv -> iservCmd hsc_env (EvalIO fhv) >>= fromEvalResult -- | Execute an action of type @IO String@ evalString :: HscEnv -> ForeignHValue -> IO String -evalString hsc_env fhv = do +evalString hsc_env fhv = liftIO $ withForeignRef fhv $ \fhv -> iservCmd hsc_env (EvalString fhv) >>= fromEvalResult -- | Execute an action of type @String -> IO String@ evalStringToIOString :: HscEnv -> ForeignHValue -> String -> IO String -evalStringToIOString hsc_env fhv str = do +evalStringToIOString hsc_env fhv str = liftIO $ withForeignRef fhv $ \fhv -> iservCmd hsc_env (EvalStringToString fhv str) >>= fromEvalResult @@ -379,12 +379,12 @@ newBreakArray hsc_env size = do mkFinalizedHValue hsc_env breakArray enableBreakpoint :: HscEnv -> ForeignRef BreakArray -> Int -> Bool -> IO () -enableBreakpoint hsc_env ref ix b = do +enableBreakpoint hsc_env ref ix b = withForeignRef ref $ \breakarray -> iservCmd hsc_env (EnableBreakpoint breakarray ix b) breakpointStatus :: HscEnv -> ForeignRef BreakArray -> Int -> IO Bool -breakpointStatus hsc_env ref ix = do +breakpointStatus hsc_env ref ix = withForeignRef ref $ \breakarray -> iservCmd hsc_env (BreakpointStatus breakarray ix) @@ -408,7 +408,7 @@ seqHValue hsc_env ref = -- | Process the result of a Seq or ResumeSeq message. #2950 handleSeqHValueStatus :: HscEnv -> EvalStatus () -> IO (EvalResult ()) -handleSeqHValueStatus hsc_env eval_status = do +handleSeqHValueStatus hsc_env eval_status = case eval_status of (EvalBreak is_exception _ ix mod_uniq resume_ctxt _) -> do -- A breakpoint was hit; inform the user and tell them diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Runtime/Linker.hs index 4203f741c6..dd3c29caa5 100644 --- a/compiler/GHC/Runtime/Linker.hs +++ b/compiler/GHC/Runtime/Linker.hs @@ -243,7 +243,7 @@ withExtendedLinkEnv dl new_env action -- lose those changes (we might have linked a new module or -- package), so the reset action only removes the names we -- added earlier. - reset_old_env = liftIO $ do + reset_old_env = liftIO $ modifyPLS_ dl $ \pls -> let cur = closure_env pls new = delListFromNameEnv cur (map fst new_env) @@ -313,7 +313,7 @@ linkCmdLineLibs :: HscEnv -> IO () linkCmdLineLibs hsc_env = do let dl = hsc_dynLinker hsc_env initDynLinker hsc_env - modifyPLS_ dl $ \pls -> do + modifyPLS_ dl $ \pls -> linkCmdLineLibs' hsc_env pls linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState @@ -915,7 +915,7 @@ dynLinkObjs hsc_env pls objs = do -- If resolving failed, unload all our -- object modules and carry on - if succeeded ok then do + if succeeded ok then return (pls1, Succeeded) else do pls2 <- unload_wkr hsc_env [] pls1 @@ -1259,7 +1259,7 @@ linkPackages hsc_env new_pkgs = do -- a lock. initDynLinker hsc_env let dl = hsc_dynLinker hsc_env - modifyPLS_ dl $ \pls -> do + modifyPLS_ dl $ \pls -> linkPackages' hsc_env new_pkgs pls linkPackages' :: HscEnv -> [UnitId] -> PersistentLinkerState diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs index 2a97e24edd..3b487e7b1a 100644 --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -80,8 +80,7 @@ initializePlugins hsc_env df | otherwise = do loadedPlugins <- loadPlugins (hsc_env { hsc_dflags = df }) let df' = df { cachedPlugins = loadedPlugins } - df'' <- withPlugins df' runDflagsPlugin df' - return df'' + withPlugins df' runDflagsPlugin df' where argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst) runDflagsPlugin p opts dynflags = dynflagsPlugin p opts dynflags diff --git a/compiler/GHC/Stg/Lift.hs b/compiler/GHC/Stg/Lift.hs index 8abd6fc67d..27e63f9313 100644 --- a/compiler/GHC/Stg/Lift.hs +++ b/compiler/GHC/Stg/Lift.hs @@ -202,11 +202,11 @@ liftRhs liftRhs mb_former_fvs rhs@(StgRhsCon ccs con args) = ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ pprStgRhs panicStgPprOpts rhs) StgRhsCon ccs con <$> traverse liftArgs args -liftRhs Nothing (StgRhsClosure _ ccs upd infos body) = do +liftRhs Nothing (StgRhsClosure _ ccs upd infos body) = -- This RHS wasn't lifted. withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> StgRhsClosure noExtFieldSilent ccs upd bndrs' <$> liftExpr body -liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body) = do +liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body) = -- This RHS was lifted. Insert extra binders for @former_fvs@. withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> do let bndrs'' = dVarSetElems former_fvs ++ bndrs' diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs index f6c8176a92..eb56a6ad09 100644 --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -178,12 +178,10 @@ cgLetNoEscapeClosure cgLetNoEscapeClosure bndr cc_slot _unused_cc args body = do platform <- getPlatform - return ( lneIdInfo platform bndr args - , code ) + return ( lneIdInfo platform bndr args, code ) where - code = forkLneBody $ do { - ; withNewTickyCounterLNE (idName bndr) args $ do - ; restoreCurrentCostCentre cc_slot + code = forkLneBody $ withNewTickyCounterLNE (idName bndr) args $ do + { restoreCurrentCostCentre cc_slot ; arg_regs <- bindArgsToRegs args ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) } diff --git a/compiler/GHC/StgToCmm/Heap.hs b/compiler/GHC/StgToCmm/Heap.hs index 6c811ba9cc..62b9785ed6 100644 --- a/compiler/GHC/StgToCmm/Heap.hs +++ b/compiler/GHC/StgToCmm/Heap.hs @@ -650,7 +650,7 @@ do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do tickyHeapCheck emitAssign hpReg bump_hp emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False) - else do + else when (checkYield && not (gopt Opt_OmitYields dflags)) $ do -- Yielding if HpLim == 0 let yielding = CmmMachOp (mo_wordEq platform) diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs index 556c1c6ffd..915b57eae0 100644 --- a/compiler/GHC/StgToCmm/Monad.hs +++ b/compiler/GHC/StgToCmm/Monad.hs @@ -734,7 +734,7 @@ emitTick = emitCgStmt . CgStmt . CmmTick emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode () emitUnwind regs = do dflags <- getDynFlags - when (debugLevel dflags > 0) $ do + when (debugLevel dflags > 0) $ emitCgStmt $ CgStmt $ CmmUnwind regs emitAssign :: CmmReg -> CmmExpr -> FCode () diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index 4a58873992..a6f2dcb6da 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -266,7 +266,7 @@ emitPrimOp dflags primop = case primop of -- First we handle various awkward cases specially. - ParOp -> \[arg] -> opIntoRegs $ \[res] -> do + ParOp -> \[arg] -> opIntoRegs $ \[res] -> -- for now, just implement this in a C function -- later, we might want to inline it. emitCCall @@ -293,13 +293,13 @@ emitPrimOp dflags primop = case primop of | otherwise = CmmLit (zeroCLit platform) emitAssign (CmmLocal res) val - GetCurrentCCSOp -> \[_] -> opIntoRegs $ \[res] -> do + GetCurrentCCSOp -> \[_] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) cccsExpr - MyThreadIdOp -> \[] -> opIntoRegs $ \[res] -> do + MyThreadIdOp -> \[] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) currentTSOExpr - ReadMutVarOp -> \[mutv] -> opIntoRegs $ \[res] -> do + ReadMutVarOp -> \[mutv] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) (cmmLoadIndexW platform mutv (fixedHdrSizeW profile) (gcWord platform)) WriteMutVarOp -> \[mutv, var] -> opIntoRegs $ \res@[] -> do @@ -320,7 +320,7 @@ emitPrimOp dflags primop = case primop of -- #define sizzeofByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes - SizeofByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do + SizeofByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) -- #define sizzeofMutableByteArrayzh(r,a) \ @@ -329,31 +329,31 @@ emitPrimOp dflags primop = case primop of -- #define getSizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes - GetSizeofMutableByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do + GetSizeofMutableByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) -- #define touchzh(o) /* nothing */ - TouchOp -> \args@[_] -> opIntoRegs $ \res@[] -> do + TouchOp -> \args@[_] -> opIntoRegs $ \res@[] -> emitPrimCall res MO_Touch args -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) - ByteArrayContents_Char -> \[arg] -> opIntoRegs $ \[res] -> do + ByteArrayContents_Char -> \[arg] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize profile)) -- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) - StableNameToIntOp -> \[arg] -> opIntoRegs $ \[res] -> do + StableNameToIntOp -> \[arg] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) - ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opIntoRegs $ \[res] -> do + ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq platform) [arg1,arg2]) -- #define addrToHValuezh(r,a) r=(P_)a - AddrToAnyOp -> \[arg] -> opIntoRegs $ \[res] -> do + AddrToAnyOp -> \[arg] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) arg -- #define hvalueToAddrzh(r, a) r=(W_)a - AnyToAddrOp -> \[arg] -> opIntoRegs $ \[res] -> do + AnyToAddrOp -> \[arg] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) arg {- Freezing arrays-of-ptrs requires changing an info table, for the @@ -366,70 +366,70 @@ emitPrimOp dflags primop = case primop of -- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_DIRTY_info); -- r = a; -- } - UnsafeFreezeArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do + UnsafeFreezeArrayOp -> \[arg] -> opIntoRegs $ \[res] -> emit $ catAGraphs [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)), mkAssign (CmmLocal res) arg ] - UnsafeFreezeArrayArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do + UnsafeFreezeArrayArrayOp -> \[arg] -> opIntoRegs $ \[res] -> emit $ catAGraphs [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)), mkAssign (CmmLocal res) arg ] - UnsafeFreezeSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do + UnsafeFreezeSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> emit $ catAGraphs [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)), mkAssign (CmmLocal res) arg ] -- #define unsafeFreezzeByteArrayzh(r,a) r=(a) - UnsafeFreezeByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do + UnsafeFreezeByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) arg -- Reading/writing pointer arrays - ReadArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> do + ReadArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadPtrArrayOp res obj ix - IndexArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> do + IndexArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadPtrArrayOp res obj ix - WriteArrayOp -> \[obj, ix, v] -> opIntoRegs $ \[] -> do + WriteArrayOp -> \[obj, ix, v] -> opIntoRegs $ \[] -> doWritePtrArrayOp obj ix v - IndexArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do + IndexArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadPtrArrayOp res obj ix - IndexArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do + IndexArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadPtrArrayOp res obj ix - ReadArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do + ReadArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadPtrArrayOp res obj ix - ReadArrayArrayOp_MutableByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do + ReadArrayArrayOp_MutableByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadPtrArrayOp res obj ix - ReadArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do + ReadArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadPtrArrayOp res obj ix - ReadArrayArrayOp_MutableArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do + ReadArrayArrayOp_MutableArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadPtrArrayOp res obj ix - WriteArrayArrayOp_ByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> do + WriteArrayArrayOp_ByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> doWritePtrArrayOp obj ix v - WriteArrayArrayOp_MutableByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> do + WriteArrayArrayOp_MutableByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> doWritePtrArrayOp obj ix v - WriteArrayArrayOp_ArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> do + WriteArrayArrayOp_ArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> doWritePtrArrayOp obj ix v - WriteArrayArrayOp_MutableArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> do + WriteArrayArrayOp_MutableArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> doWritePtrArrayOp obj ix v - ReadSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> do + ReadSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadSmallPtrArrayOp res obj ix - IndexSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> do + IndexSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadSmallPtrArrayOp res obj ix - WriteSmallArrayOp -> \[obj,ix,v] -> opIntoRegs $ \[] -> do + WriteSmallArrayOp -> \[obj,ix,v] -> opIntoRegs $ \[] -> doWriteSmallPtrArrayOp obj ix v -- Getting the size of pointer arrays - SizeofArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do + SizeofArrayOp -> \[arg] -> opIntoRegs $ \[res] -> emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform))) (bWord platform)) SizeofMutableArrayOp -> emitPrimOp dflags SizeofArrayOp SizeofArrayArrayOp -> emitPrimOp dflags SizeofArrayOp SizeofMutableArrayArrayOp -> emitPrimOp dflags SizeofArrayOp - SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do + SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform))) @@ -440,409 +440,409 @@ emitPrimOp dflags primop = case primop of -- IndexXXXoffAddr - IndexOffAddrOp_Char -> \args -> opIntoRegs $ \res -> do + IndexOffAddrOp_Char -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args - IndexOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> do + IndexOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args - IndexOffAddrOp_Int -> \args -> opIntoRegs $ \res -> do + IndexOffAddrOp_Int -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args - IndexOffAddrOp_Word -> \args -> opIntoRegs $ \res -> do + IndexOffAddrOp_Word -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args - IndexOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> do + IndexOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args - IndexOffAddrOp_Float -> \args -> opIntoRegs $ \res -> do + IndexOffAddrOp_Float -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing f32 res args - IndexOffAddrOp_Double -> \args -> opIntoRegs $ \res -> do + IndexOffAddrOp_Double -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing f64 res args - IndexOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> do + IndexOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args - IndexOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> do + IndexOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_s_8ToWord platform)) b8 res args - IndexOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> do + IndexOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_s_16ToWord platform)) b16 res args - IndexOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> do + IndexOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_s_32ToWord platform)) b32 res args - IndexOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> do + IndexOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing b64 res args - IndexOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> do + IndexOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args - IndexOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> do + IndexOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_u_16ToWord platform)) b16 res args - IndexOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> do + IndexOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args - IndexOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> do + IndexOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing b64 res args -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr. - ReadOffAddrOp_Char -> \args -> opIntoRegs $ \res -> do + ReadOffAddrOp_Char -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args - ReadOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> do + ReadOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args - ReadOffAddrOp_Int -> \args -> opIntoRegs $ \res -> do + ReadOffAddrOp_Int -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args - ReadOffAddrOp_Word -> \args -> opIntoRegs $ \res -> do + ReadOffAddrOp_Word -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args - ReadOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> do + ReadOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args - ReadOffAddrOp_Float -> \args -> opIntoRegs $ \res -> do + ReadOffAddrOp_Float -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing f32 res args - ReadOffAddrOp_Double -> \args -> opIntoRegs $ \res -> do + ReadOffAddrOp_Double -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing f64 res args - ReadOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> do + ReadOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing (bWord platform) res args - ReadOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> do + ReadOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_s_8ToWord platform)) b8 res args - ReadOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> do + ReadOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_s_16ToWord platform)) b16 res args - ReadOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> do + ReadOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_s_32ToWord platform)) b32 res args - ReadOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> do + ReadOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing b64 res args - ReadOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> do + ReadOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args - ReadOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> do + ReadOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_u_16ToWord platform)) b16 res args - ReadOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> do + ReadOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args - ReadOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> do + ReadOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing b64 res args -- IndexXXXArray - IndexByteArrayOp_Char -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Char -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args - IndexByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args - IndexByteArrayOp_Int -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Int -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args - IndexByteArrayOp_Word -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Word -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args - IndexByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args - IndexByteArrayOp_Float -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Float -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing f32 res args - IndexByteArrayOp_Double -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Double -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing f64 res args - IndexByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args - IndexByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_s_8ToWord platform)) b8 res args - IndexByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_s_16ToWord platform)) b16 res args - IndexByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_s_32ToWord platform)) b32 res args - IndexByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing b64 res args - IndexByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args - IndexByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_u_16ToWord platform)) b16 res args - IndexByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args - IndexByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing b64 res args -- ReadXXXArray, identical to IndexXXXArray. - ReadByteArrayOp_Char -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Char -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args - ReadByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args - ReadByteArrayOp_Int -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Int -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args - ReadByteArrayOp_Word -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Word -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args - ReadByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args - ReadByteArrayOp_Float -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Float -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing f32 res args - ReadByteArrayOp_Double -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Double -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing f64 res args - ReadByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing (bWord platform) res args - ReadByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_s_8ToWord platform)) b8 res args - ReadByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_s_16ToWord platform)) b16 res args - ReadByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_s_32ToWord platform)) b32 res args - ReadByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing b64 res args - ReadByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args - ReadByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_u_16ToWord platform)) b16 res args - ReadByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args - ReadByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOp Nothing b64 res args -- IndexWord8ArrayAsXXX - IndexByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_u_8ToWord platform)) b8 b8 res args - IndexByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args - IndexByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args - IndexByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args - IndexByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args - IndexByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing f32 b8 res args - IndexByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing f64 b8 res args - IndexByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args - IndexByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_s_16ToWord platform)) b16 b8 res args - IndexByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_s_32ToWord platform)) b32 b8 res args - IndexByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing b64 b8 res args - IndexByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_u_16ToWord platform)) b16 b8 res args - IndexByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args - IndexByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> do + IndexByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing b64 b8 res args -- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX - ReadByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_u_8ToWord platform)) b8 b8 res args - ReadByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args - ReadByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args - ReadByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args - ReadByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args - ReadByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing f32 b8 res args - ReadByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing f64 b8 res args - ReadByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing (bWord platform) b8 res args - ReadByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_s_16ToWord platform)) b16 b8 res args - ReadByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_s_32ToWord platform)) b32 b8 res args - ReadByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing b64 b8 res args - ReadByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_u_16ToWord platform)) b16 b8 res args - ReadByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args - ReadByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> do + ReadByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> doIndexByteArrayOpAs Nothing b64 b8 res args -- WriteXXXoffAddr - WriteOffAddrOp_Char -> \args -> opIntoRegs $ \res -> do + WriteOffAddrOp_Char -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp (Just (mo_WordTo8 platform)) b8 res args - WriteOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> do + WriteOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args - WriteOffAddrOp_Int -> \args -> opIntoRegs $ \res -> do + WriteOffAddrOp_Int -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp Nothing (bWord platform) res args - WriteOffAddrOp_Word -> \args -> opIntoRegs $ \res -> do + WriteOffAddrOp_Word -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp Nothing (bWord platform) res args - WriteOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> do + WriteOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp Nothing (bWord platform) res args - WriteOffAddrOp_Float -> \args -> opIntoRegs $ \res -> do + WriteOffAddrOp_Float -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp Nothing f32 res args - WriteOffAddrOp_Double -> \args -> opIntoRegs $ \res -> do + WriteOffAddrOp_Double -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp Nothing f64 res args - WriteOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> do + WriteOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp Nothing (bWord platform) res args - WriteOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> do + WriteOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp (Just (mo_WordTo8 platform)) b8 res args - WriteOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> do + WriteOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp (Just (mo_WordTo16 platform)) b16 res args - WriteOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> do + WriteOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args - WriteOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> do + WriteOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp Nothing b64 res args - WriteOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> do + WriteOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp (Just (mo_WordTo8 platform)) b8 res args - WriteOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> do + WriteOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp (Just (mo_WordTo16 platform)) b16 res args - WriteOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> do + WriteOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args - WriteOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> do + WriteOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> doWriteOffAddrOp Nothing b64 res args -- WriteXXXArray - WriteByteArrayOp_Char -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Char -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args - WriteByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args - WriteByteArrayOp_Int -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Int -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing (bWord platform) res args - WriteByteArrayOp_Word -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Word -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing (bWord platform) res args - WriteByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing (bWord platform) res args - WriteByteArrayOp_Float -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Float -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing f32 res args - WriteByteArrayOp_Double -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Double -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing f64 res args - WriteByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing (bWord platform) res args - WriteByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args - WriteByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo16 platform)) b16 res args - WriteByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args - WriteByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing b64 res args - WriteByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args - WriteByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo16 platform)) b16 res args - WriteByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args - WriteByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing b64 res args -- WriteInt8ArrayAsXXX - WriteByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args - WriteByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args - WriteByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo16 platform)) b8 res args - WriteByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args - WriteByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing b8 res args - WriteByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo16 platform)) b8 res args - WriteByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args - WriteByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> do + WriteByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> doWriteByteArrayOp Nothing b8 res args -- Copying and setting byte arrays - CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] -> do + CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] -> doCopyByteArrayOp src src_off dst dst_off n - CopyMutableByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] -> do + CopyMutableByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] -> doCopyMutableByteArrayOp src src_off dst dst_off n - CopyByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] -> do + CopyByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] -> doCopyByteArrayToAddrOp src src_off dst n - CopyMutableByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] -> do + CopyMutableByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] -> doCopyMutableByteArrayToAddrOp src src_off dst n - CopyAddrToByteArrayOp -> \[src,dst,dst_off,n] -> opIntoRegs $ \[] -> do + CopyAddrToByteArrayOp -> \[src,dst,dst_off,n] -> opIntoRegs $ \[] -> doCopyAddrToByteArrayOp src dst dst_off n - SetByteArrayOp -> \[ba,off,len,c] -> opIntoRegs $ \[] -> do + SetByteArrayOp -> \[ba,off,len,c] -> opIntoRegs $ \[] -> doSetByteArrayOp ba off len c -- Comparing byte arrays - CompareByteArraysOp -> \[ba1,ba1_off,ba2,ba2_off,n] -> opIntoRegs $ \[res] -> do + CompareByteArraysOp -> \[ba1,ba1_off,ba2,ba2_off,n] -> opIntoRegs $ \[res] -> doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n - BSwap16Op -> \[w] -> opIntoRegs $ \[res] -> do + BSwap16Op -> \[w] -> opIntoRegs $ \[res] -> emitBSwapCall res w W16 - BSwap32Op -> \[w] -> opIntoRegs $ \[res] -> do + BSwap32Op -> \[w] -> opIntoRegs $ \[res] -> emitBSwapCall res w W32 - BSwap64Op -> \[w] -> opIntoRegs $ \[res] -> do + BSwap64Op -> \[w] -> opIntoRegs $ \[res] -> emitBSwapCall res w W64 - BSwapOp -> \[w] -> opIntoRegs $ \[res] -> do + BSwapOp -> \[w] -> opIntoRegs $ \[res] -> emitBSwapCall res w (wordWidth platform) - BRev8Op -> \[w] -> opIntoRegs $ \[res] -> do + BRev8Op -> \[w] -> opIntoRegs $ \[res] -> emitBRevCall res w W8 - BRev16Op -> \[w] -> opIntoRegs $ \[res] -> do + BRev16Op -> \[w] -> opIntoRegs $ \[res] -> emitBRevCall res w W16 - BRev32Op -> \[w] -> opIntoRegs $ \[res] -> do + BRev32Op -> \[w] -> opIntoRegs $ \[res] -> emitBRevCall res w W32 - BRev64Op -> \[w] -> opIntoRegs $ \[res] -> do + BRev64Op -> \[w] -> opIntoRegs $ \[res] -> emitBRevCall res w W64 - BRevOp -> \[w] -> opIntoRegs $ \[res] -> do + BRevOp -> \[w] -> opIntoRegs $ \[res] -> emitBRevCall res w (wordWidth platform) -- Population count - PopCnt8Op -> \[w] -> opIntoRegs $ \[res] -> do + PopCnt8Op -> \[w] -> opIntoRegs $ \[res] -> emitPopCntCall res w W8 - PopCnt16Op -> \[w] -> opIntoRegs $ \[res] -> do + PopCnt16Op -> \[w] -> opIntoRegs $ \[res] -> emitPopCntCall res w W16 - PopCnt32Op -> \[w] -> opIntoRegs $ \[res] -> do + PopCnt32Op -> \[w] -> opIntoRegs $ \[res] -> emitPopCntCall res w W32 - PopCnt64Op -> \[w] -> opIntoRegs $ \[res] -> do + PopCnt64Op -> \[w] -> opIntoRegs $ \[res] -> emitPopCntCall res w W64 - PopCntOp -> \[w] -> opIntoRegs $ \[res] -> do + PopCntOp -> \[w] -> opIntoRegs $ \[res] -> emitPopCntCall res w (wordWidth platform) -- Parallel bit deposit - Pdep8Op -> \[src, mask] -> opIntoRegs $ \[res] -> do + Pdep8Op -> \[src, mask] -> opIntoRegs $ \[res] -> emitPdepCall res src mask W8 - Pdep16Op -> \[src, mask] -> opIntoRegs $ \[res] -> do + Pdep16Op -> \[src, mask] -> opIntoRegs $ \[res] -> emitPdepCall res src mask W16 - Pdep32Op -> \[src, mask] -> opIntoRegs $ \[res] -> do + Pdep32Op -> \[src, mask] -> opIntoRegs $ \[res] -> emitPdepCall res src mask W32 - Pdep64Op -> \[src, mask] -> opIntoRegs $ \[res] -> do + Pdep64Op -> \[src, mask] -> opIntoRegs $ \[res] -> emitPdepCall res src mask W64 - PdepOp -> \[src, mask] -> opIntoRegs $ \[res] -> do + PdepOp -> \[src, mask] -> opIntoRegs $ \[res] -> emitPdepCall res src mask (wordWidth platform) -- Parallel bit extract - Pext8Op -> \[src, mask] -> opIntoRegs $ \[res] -> do + Pext8Op -> \[src, mask] -> opIntoRegs $ \[res] -> emitPextCall res src mask W8 - Pext16Op -> \[src, mask] -> opIntoRegs $ \[res] -> do + Pext16Op -> \[src, mask] -> opIntoRegs $ \[res] -> emitPextCall res src mask W16 - Pext32Op -> \[src, mask] -> opIntoRegs $ \[res] -> do + Pext32Op -> \[src, mask] -> opIntoRegs $ \[res] -> emitPextCall res src mask W32 - Pext64Op -> \[src, mask] -> opIntoRegs $ \[res] -> do + Pext64Op -> \[src, mask] -> opIntoRegs $ \[res] -> emitPextCall res src mask W64 - PextOp -> \[src, mask] -> opIntoRegs $ \[res] -> do + PextOp -> \[src, mask] -> opIntoRegs $ \[res] -> emitPextCall res src mask (wordWidth platform) -- count leading zeros - Clz8Op -> \[w] -> opIntoRegs $ \[res] -> do + Clz8Op -> \[w] -> opIntoRegs $ \[res] -> emitClzCall res w W8 - Clz16Op -> \[w] -> opIntoRegs $ \[res] -> do + Clz16Op -> \[w] -> opIntoRegs $ \[res] -> emitClzCall res w W16 - Clz32Op -> \[w] -> opIntoRegs $ \[res] -> do + Clz32Op -> \[w] -> opIntoRegs $ \[res] -> emitClzCall res w W32 - Clz64Op -> \[w] -> opIntoRegs $ \[res] -> do + Clz64Op -> \[w] -> opIntoRegs $ \[res] -> emitClzCall res w W64 - ClzOp -> \[w] -> opIntoRegs $ \[res] -> do + ClzOp -> \[w] -> opIntoRegs $ \[res] -> emitClzCall res w (wordWidth platform) -- count trailing zeros - Ctz8Op -> \[w] -> opIntoRegs $ \[res] -> do + Ctz8Op -> \[w] -> opIntoRegs $ \[res] -> emitCtzCall res w W8 - Ctz16Op -> \[w] -> opIntoRegs $ \[res] -> do + Ctz16Op -> \[w] -> opIntoRegs $ \[res] -> emitCtzCall res w W16 - Ctz32Op -> \[w] -> opIntoRegs $ \[res] -> do + Ctz32Op -> \[w] -> opIntoRegs $ \[res] -> emitCtzCall res w W32 - Ctz64Op -> \[w] -> opIntoRegs $ \[res] -> do + Ctz64Op -> \[w] -> opIntoRegs $ \[res] -> emitCtzCall res w W64 - CtzOp -> \[w] -> opIntoRegs $ \[res] -> do + CtzOp -> \[w] -> opIntoRegs $ \[res] -> emitCtzCall res w (wordWidth platform) -- Unsigned int to floating point conversions - WordToFloatOp -> \[w] -> opIntoRegs $ \[res] -> do + WordToFloatOp -> \[w] -> opIntoRegs $ \[res] -> emitPrimCall [res] (MO_UF_Conv W32) [w] - WordToDoubleOp -> \[w] -> opIntoRegs $ \[res] -> do + WordToDoubleOp -> \[w] -> opIntoRegs $ \[res] -> emitPrimCall [res] (MO_UF_Conv W64) [w] -- Atomic operations @@ -1003,59 +1003,59 @@ emitPrimOp dflags primop = case primop of ty = vecCmmCat vcat w -- Prefetch - PrefetchByteArrayOp3 -> \args -> opIntoRegs $ \[] -> do + PrefetchByteArrayOp3 -> \args -> opIntoRegs $ \[] -> doPrefetchByteArrayOp 3 args - PrefetchMutableByteArrayOp3 -> \args -> opIntoRegs $ \[] -> do + PrefetchMutableByteArrayOp3 -> \args -> opIntoRegs $ \[] -> doPrefetchMutableByteArrayOp 3 args - PrefetchAddrOp3 -> \args -> opIntoRegs $ \[] -> do + PrefetchAddrOp3 -> \args -> opIntoRegs $ \[] -> doPrefetchAddrOp 3 args - PrefetchValueOp3 -> \args -> opIntoRegs $ \[] -> do + PrefetchValueOp3 -> \args -> opIntoRegs $ \[] -> doPrefetchValueOp 3 args - PrefetchByteArrayOp2 -> \args -> opIntoRegs $ \[] -> do + PrefetchByteArrayOp2 -> \args -> opIntoRegs $ \[] -> doPrefetchByteArrayOp 2 args - PrefetchMutableByteArrayOp2 -> \args -> opIntoRegs $ \[] -> do + PrefetchMutableByteArrayOp2 -> \args -> opIntoRegs $ \[] -> doPrefetchMutableByteArrayOp 2 args - PrefetchAddrOp2 -> \args -> opIntoRegs $ \[] -> do + PrefetchAddrOp2 -> \args -> opIntoRegs $ \[] -> doPrefetchAddrOp 2 args - PrefetchValueOp2 -> \args -> opIntoRegs $ \[] -> do + PrefetchValueOp2 -> \args -> opIntoRegs $ \[] -> doPrefetchValueOp 2 args - PrefetchByteArrayOp1 -> \args -> opIntoRegs $ \[] -> do + PrefetchByteArrayOp1 -> \args -> opIntoRegs $ \[] -> doPrefetchByteArrayOp 1 args - PrefetchMutableByteArrayOp1 -> \args -> opIntoRegs $ \[] -> do + PrefetchMutableByteArrayOp1 -> \args -> opIntoRegs $ \[] -> doPrefetchMutableByteArrayOp 1 args - PrefetchAddrOp1 -> \args -> opIntoRegs $ \[] -> do + PrefetchAddrOp1 -> \args -> opIntoRegs $ \[] -> doPrefetchAddrOp 1 args - PrefetchValueOp1 -> \args -> opIntoRegs $ \[] -> do + PrefetchValueOp1 -> \args -> opIntoRegs $ \[] -> doPrefetchValueOp 1 args - PrefetchByteArrayOp0 -> \args -> opIntoRegs $ \[] -> do + PrefetchByteArrayOp0 -> \args -> opIntoRegs $ \[] -> doPrefetchByteArrayOp 0 args - PrefetchMutableByteArrayOp0 -> \args -> opIntoRegs $ \[] -> do + PrefetchMutableByteArrayOp0 -> \args -> opIntoRegs $ \[] -> doPrefetchMutableByteArrayOp 0 args - PrefetchAddrOp0 -> \args -> opIntoRegs $ \[] -> do + PrefetchAddrOp0 -> \args -> opIntoRegs $ \[] -> doPrefetchAddrOp 0 args - PrefetchValueOp0 -> \args -> opIntoRegs $ \[] -> do + PrefetchValueOp0 -> \args -> opIntoRegs $ \[] -> doPrefetchValueOp 0 args -- Atomic read-modify-write - FetchAddByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do + FetchAddByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> doAtomicRMW res AMO_Add mba ix (bWord platform) n - FetchSubByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do + FetchSubByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> doAtomicRMW res AMO_Sub mba ix (bWord platform) n - FetchAndByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do + FetchAndByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> doAtomicRMW res AMO_And mba ix (bWord platform) n - FetchNandByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do + FetchNandByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> doAtomicRMW res AMO_Nand mba ix (bWord platform) n - FetchOrByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do + FetchOrByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> doAtomicRMW res AMO_Or mba ix (bWord platform) n - FetchXorByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do + FetchXorByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> doAtomicRMW res AMO_Xor mba ix (bWord platform) n - AtomicReadByteArrayOp_Int -> \[mba, ix] -> opIntoRegs $ \[res] -> do + AtomicReadByteArrayOp_Int -> \[mba, ix] -> opIntoRegs $ \[res] -> doAtomicReadByteArray res mba ix (bWord platform) - AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> opIntoRegs $ \[] -> do + AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> opIntoRegs $ \[] -> doAtomicWriteByteArray mba ix (bWord platform) val - CasByteArrayOp_Int -> \[mba, ix, old, new] -> opIntoRegs $ \[res] -> do + CasByteArrayOp_Int -> \[mba, ix, old, new] -> opIntoRegs $ \[res] -> doCasByteArray res mba ix (bWord platform) old new -- The rest just translate straightforwardly @@ -2170,7 +2170,7 @@ vecElemProjectCast _ _ _ = Nothing checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode () checkVecCompatibility dflags vcat l w = do - when (backend dflags /= LLVM) $ do + when (backend dflags /= LLVM) $ sorry $ unlines ["SIMD vector instructions require the LLVM back-end." ,"Please use -fllvm."] check vecWidth vcat l w @@ -2933,7 +2933,7 @@ doCasByteArray res mba idx idx_ty old new = do -- | Emit a call to @memcpy@. emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () -emitMemcpyCall dst src n align = do +emitMemcpyCall dst src n align = emitPrimCall [ {-no results-} ] (MO_Memcpy (alignmentBytes align)) @@ -2941,7 +2941,7 @@ emitMemcpyCall dst src n align = do -- | Emit a call to @memmove@. emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () -emitMemmoveCall dst src n align = do +emitMemmoveCall dst src n align = emitPrimCall [ {- no results -} ] (MO_Memmove (alignmentBytes align)) @@ -2950,7 +2950,7 @@ emitMemmoveCall dst src n align = do -- | Emit a call to @memset@. The second argument must fit inside an -- unsigned char. emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () -emitMemsetCall dst c n align = do +emitMemsetCall dst c n align = emitPrimCall [ {- no results -} ] (MO_Memset (alignmentBytes align)) @@ -2974,56 +2974,56 @@ emitMemcmpCall res ptr1 ptr2 n align = do (MO_Memcmp align) [ ptr1, ptr2, n ] - unless is32Bit $ do + unless is32Bit $ emit $ mkAssign (CmmLocal res) (CmmMachOp (mo_s_32ToWord platform) [(CmmReg (CmmLocal cres))]) emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode () -emitBSwapCall res x width = do +emitBSwapCall res x width = emitPrimCall [ res ] (MO_BSwap width) [ x ] emitBRevCall :: LocalReg -> CmmExpr -> Width -> FCode () -emitBRevCall res x width = do +emitBRevCall res x width = emitPrimCall [ res ] (MO_BRev width) [ x ] emitPopCntCall :: LocalReg -> CmmExpr -> Width -> FCode () -emitPopCntCall res x width = do +emitPopCntCall res x width = emitPrimCall [ res ] (MO_PopCnt width) [ x ] emitPdepCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode () -emitPdepCall res x y width = do +emitPdepCall res x y width = emitPrimCall [ res ] (MO_Pdep width) [ x, y ] emitPextCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode () -emitPextCall res x y width = do +emitPextCall res x y width = emitPrimCall [ res ] (MO_Pext width) [ x, y ] emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode () -emitClzCall res x width = do +emitClzCall res x width = emitPrimCall [ res ] (MO_Clz width) [ x ] emitCtzCall :: LocalReg -> CmmExpr -> Width -> FCode () -emitCtzCall res x width = do +emitCtzCall res x width = emitPrimCall [ res ] (MO_Ctz width) diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs index 355cc6a781..473e240a54 100644 --- a/compiler/GHC/StgToCmm/Prof.hs +++ b/compiler/GHC/StgToCmm/Prof.hs @@ -186,7 +186,7 @@ enterCostCentreThunk closure = enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode () enterCostCentreFun ccs closure = - ifProfiling $ do + ifProfiling $ if isCurrentCCS ccs then do platform <- getPlatform emitRtsCall rtsUnitId (fsLit "enterFunCCS") diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs index 190202efb9..dbb4481d72 100644 --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -608,7 +608,7 @@ whenUpdRemSetEnabled code = do -- remembered set. emitUpdRemSetPush :: CmmExpr -- ^ value of pointer which was overwritten -> FCode () -emitUpdRemSetPush ptr = do +emitUpdRemSetPush ptr = emitRtsCall rtsUnitId (fsLit "updateRemembSetPushClosure_") @@ -618,7 +618,7 @@ emitUpdRemSetPush ptr = do emitUpdRemSetPushThunk :: CmmExpr -- ^ the thunk -> FCode () -emitUpdRemSetPushThunk ptr = do +emitUpdRemSetPushThunk ptr = emitRtsCall rtsUnitId (fsLit "updateRemembSetPushThunk_") diff --git a/compiler/GHC/SysTools/ExtraObj.hs b/compiler/GHC/SysTools/ExtraObj.hs index 9208c3870d..1b728fb067 100644 --- a/compiler/GHC/SysTools/ExtraObj.hs +++ b/compiler/GHC/SysTools/ExtraObj.hs @@ -79,7 +79,7 @@ mkExtraObj dflags extn xs -- mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath mkExtraObjToLinkIntoBinary dflags = do - when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do + when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ putLogMsg dflags NoReason SevInfo noSrcSpan $ withPprStyle defaultUserStyle (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ diff --git a/compiler/GHC/SysTools/Info.hs b/compiler/GHC/SysTools/Info.hs index fec6ecff15..fe848cbb12 100644 --- a/compiler/GHC/SysTools/Info.hs +++ b/compiler/GHC/SysTools/Info.hs @@ -119,9 +119,9 @@ getLinkerInfo' dflags = do let platform = targetPlatform dflags os = platformOS platform (pgm,args0) = pgm_l dflags - args1 = map Option (getOpts dflags opt_l) - args2 = args0 ++ args1 - args3 = filter notNull (map showOpt args2) + args1 = map Option (getOpts dflags opt_l) + args2 = args0 ++ args1 + args3 = filter notNull (map showOpt args2) -- Try to grab the info from the process output. parseLinkerInfo stdo _stde _exitc @@ -142,68 +142,67 @@ getLinkerInfo' dflags = do return (GnuGold [Option "-Wl,--no-as-needed"]) | any ("LLD" `isPrefixOf`) stdo = - return (LlvmLLD $ map Option [ - -- see Note [ELF needed shared libs] - "-Wl,--no-as-needed"]) + return (LlvmLLD $ map Option [ --see Note [ELF needed shared libs] + "-Wl,--no-as-needed"]) -- Unknown linker. | otherwise = fail "invalid --version output, or linker is unsupported" -- Process the executable call - info <- catchIO (do - case os of - OSSolaris2 -> - -- Solaris uses its own Solaris linker. Even all - -- GNU C are recommended to configure with Solaris - -- linker instead of using GNU binutils linker. Also - -- all GCC distributed with Solaris follows this rule - -- precisely so we assume here, the Solaris linker is - -- used. - return $ SolarisLD [] - OSAIX -> - -- IBM AIX uses its own non-binutils linker as well - return $ AixLD [] - OSDarwin -> - -- Darwin has neither GNU Gold or GNU LD, but a strange linker - -- that doesn't support --version. We can just assume that's - -- what we're using. - return $ DarwinLD [] - OSMinGW32 -> - -- GHC doesn't support anything but GNU ld on Windows anyway. - -- Process creation is also fairly expensive on win32, so - -- we short-circuit here. - return $ GnuLD $ map Option - [ -- Reduce ld memory usage - "-Wl,--hash-size=31" - , "-Wl,--reduce-memory-overheads" - -- Emit gcc stack checks - -- Note [Windows stack usage] - , "-fstack-check" - -- Force static linking of libGCC - -- Note [Windows static libGCC] - , "-static-libgcc" ] - _ -> do - -- In practice, we use the compiler as the linker here. Pass - -- -Wl,--version to get linker version info. - (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm - (["-Wl,--version"] ++ args3) - c_locale_env - -- Split the output by lines to make certain kinds - -- of processing easier. In particular, 'clang' and 'gcc' - -- have slightly different outputs for '-Wl,--version', but - -- it's still easy to figure out. - parseLinkerInfo (lines stdo) (lines stde) exitc - ) - (\err -> do - debugTraceMsg dflags 2 - (text "Error (figuring out linker information):" <+> - text (show err)) - errorMsg dflags $ hang (text "Warning:") 9 $ - text "Couldn't figure out linker information!" $$ - text "Make sure you're using GNU ld, GNU gold" <+> - text "or the built in OS X linker, etc." - return UnknownLD) - return info + catchIO ( + case os of + OSSolaris2 -> + -- Solaris uses its own Solaris linker. Even all + -- GNU C are recommended to configure with Solaris + -- linker instead of using GNU binutils linker. Also + -- all GCC distributed with Solaris follows this rule + -- precisely so we assume here, the Solaris linker is + -- used. + return $ SolarisLD [] + OSAIX -> + -- IBM AIX uses its own non-binutils linker as well + return $ AixLD [] + OSDarwin -> + -- Darwin has neither GNU Gold or GNU LD, but a strange linker + -- that doesn't support --version. We can just assume that's + -- what we're using. + return $ DarwinLD [] + OSMinGW32 -> + -- GHC doesn't support anything but GNU ld on Windows anyway. + -- Process creation is also fairly expensive on win32, so + -- we short-circuit here. + return $ GnuLD $ map Option + [ -- Reduce ld memory usage + "-Wl,--hash-size=31" + , "-Wl,--reduce-memory-overheads" + -- Emit gcc stack checks + -- Note [Windows stack usage] + , "-fstack-check" + -- Force static linking of libGCC + -- Note [Windows static libGCC] + , "-static-libgcc" ] + _ -> do + -- In practice, we use the compiler as the linker here. Pass + -- -Wl,--version to get linker version info. + (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm + (["-Wl,--version"] ++ args3) + c_locale_env + -- Split the output by lines to make certain kinds + -- of processing easier. In particular, 'clang' and 'gcc' + -- have slightly different outputs for '-Wl,--version', but + -- it's still easy to figure out. + parseLinkerInfo (lines stdo) (lines stde) exitc + ) + (\err -> do + debugTraceMsg dflags 2 + (text "Error (figuring out linker information):" <+> + text (show err)) + errorMsg dflags $ hang (text "Warning:") 9 $ + text "Couldn't figure out linker information!" $$ + text "Make sure you're using GNU ld, GNU gold" <+> + text "or the built in OS X linker, etc." + return UnknownLD + ) -- Grab compiler info and cache it in DynFlags. getCompilerInfo :: DynFlags -> IO CompilerInfo @@ -244,19 +243,19 @@ getCompilerInfo' dflags = do | otherwise = fail $ "invalid -v output, or compiler is unsupported: " ++ unlines stde -- Process the executable call - info <- catchIO (do - (exitc, stdo, stde) <- - readProcessEnvWithExitCode pgm ["-v"] c_locale_env - -- Split the output by lines to make certain kinds - -- of processing easier. - parseCompilerInfo (lines stdo) (lines stde) exitc - ) - (\err -> do - debugTraceMsg dflags 2 - (text "Error (figuring out C compiler information):" <+> - text (show err)) - errorMsg dflags $ hang (text "Warning:") 9 $ - text "Couldn't figure out C compiler information!" $$ - text "Make sure you're using GNU gcc, or clang" - return UnknownCC) - return info + catchIO (do + (exitc, stdo, stde) <- + readProcessEnvWithExitCode pgm ["-v"] c_locale_env + -- Split the output by lines to make certain kinds + -- of processing easier. + parseCompilerInfo (lines stdo) (lines stde) exitc + ) + (\err -> do + debugTraceMsg dflags 2 + (text "Error (figuring out C compiler information):" <+> + text (show err)) + errorMsg dflags $ hang (text "Warning:") 9 $ + text "Couldn't figure out C compiler information!" $$ + text "Make sure you're using GNU gcc, or clang" + return UnknownCC + ) diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs index 009723f795..62f3f0d258 100644 --- a/compiler/GHC/SysTools/Process.hs +++ b/compiler/GHC/SysTools/Process.hs @@ -203,7 +203,7 @@ runSomethingFiltered :: DynFlags -> (String->String) -> String -> String -> [Option] -> Maybe FilePath -> Maybe [(String,String)] -> IO () -runSomethingFiltered dflags filter_fn phase_name pgm args mb_cwd mb_env = do +runSomethingFiltered dflags filter_fn phase_name pgm args mb_cwd mb_env = runSomethingWith dflags phase_name pgm args $ \real_args -> do r <- builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env return (r,()) @@ -325,12 +325,12 @@ readerProc chan hdl filter_fn = loop (l:ls) in_err = case in_err of Just err@(BuildError srcLoc msg) - | leading_whitespace l -> do + | leading_whitespace l -> loop ls (Just (BuildError srcLoc (msg $$ text l))) | otherwise -> do writeChan chan err checkError l ls - Nothing -> do + Nothing -> checkError l ls _ -> panic "readerProc/loop" diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs index 4e78f52f34..8b6bd70bbd 100644 --- a/compiler/GHC/SysTools/Tasks.hs +++ b/compiler/GHC/SysTools/Tasks.hs @@ -191,9 +191,8 @@ runClang dflags args = traceToolCommand dflags "clang" $ do args1 = map Option (getOpts dflags opt_a) args2 = args0 ++ args1 ++ args mb_env <- getGccEnv args2 - catch (do - runSomethingFiltered dflags id "Clang (Assembler)" clang args2 Nothing mb_env - ) + catch + (runSomethingFiltered dflags id "Clang (Assembler)" clang args2 Nothing mb_env) (\(err :: SomeException) -> do errorMsg dflags $ text ("Error running clang! you need clang installed to use the" ++ diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs index 7661000723..9e9adbb961 100644 --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -26,11 +26,10 @@ import GHC.Tc.Types.Origin import GHC.Core.Predicate import GHC.Tc.Deriv.Infer import GHC.Tc.Deriv.Utils -import GHC.Tc.Validity( allDistinctTyVars ) import GHC.Tc.TyCl.Class( instDeclCtxt3, tcATDefault ) import GHC.Tc.Utils.Env import GHC.Tc.Deriv.Generate -import GHC.Tc.Validity( checkValidInstHead ) +import GHC.Tc.Validity( allDistinctTyVars, checkValidInstHead ) import GHC.Core.InstEnv import GHC.Tc.Utils.Instantiate import GHC.Core.FamInstEnv diff --git a/compiler/GHC/Tc/Deriv/Infer.hs b/compiler/GHC/Tc/Deriv/Infer.hs index eb81587eb7..d65564d1da 100644 --- a/compiler/GHC/Tc/Deriv/Infer.hs +++ b/compiler/GHC/Tc/Deriv/Infer.hs @@ -368,8 +368,7 @@ inferConstraintsAnyclass ; return (mkThetaOrigin (mkDerivOrigin wildcard) TypeLevel meth_tvs dm_tvs meth_theta (tau_eq:dm_theta)) } - ; theta_origins <- lift $ mapM do_one_meth gen_dms - ; return theta_origins } + ; lift $ mapM do_one_meth gen_dms } -- Like 'inferConstraints', but used only for @GeneralizedNewtypeDeriving@ and -- @DerivingVia@. Since both strategies generate code involving 'coerce', the diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index 298ea5b138..15ca20b738 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -513,8 +513,7 @@ tcExpr (HsMultiIf _ alts) res_ty where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody } tcExpr (HsDo _ do_or_lc stmts) res_ty - = do { expr' <- tcDoStmts do_or_lc stmts res_ty - ; return expr' } + = tcDoStmts do_or_lc stmts res_ty tcExpr (HsProc x pat cmd) res_ty = do { (pat', cmd', coi) <- tcProc pat cmd res_ty @@ -1691,7 +1690,7 @@ checkClosedInStaticForm name = do checkClosed type_env n = checkLoop type_env (unitNameSet n) n checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason - checkLoop type_env visited n = do + checkLoop type_env visited n = -- The @visited@ set is an accumulating parameter that contains the set of -- visited nodes, so we avoid repeating cycles in the traversal. case lookupNameEnv type_env n of diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index 9c67345b7f..889923743c 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -77,7 +77,6 @@ import GHC.Tc.Types.Origin import GHC.Core.Predicate import GHC.Tc.Types.Constraint import GHC.Tc.Utils.Env -import GHC.Tc.Utils.Instantiate( tcInstInvisibleTyBinders ) import GHC.Tc.Utils.TcMType import GHC.Tc.Validity import GHC.Tc.Utils.Unify @@ -87,7 +86,8 @@ import GHC.Tc.Utils.Zonk import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr import GHC.Tc.Utils.TcType -import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBindersN, tcInstInvisibleTyBinder ) +import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBindersN, + tcInstInvisibleTyBinder ) import GHC.Core.Type import GHC.Builtin.Types.Prim import GHC.Types.Name.Env diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs index 2e94d477b1..d15777cc5f 100644 --- a/compiler/GHC/Tc/Instance/Class.hs +++ b/compiler/GHC/Tc/Instance/Class.hs @@ -15,14 +15,14 @@ import GHC.Prelude import GHC.Driver.Session + import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType -import GHC.Tc.Utils.Instantiate( tcInstType ) +import GHC.Tc.Utils.Instantiate(instDFunType, tcInstType) import GHC.Tc.Instance.Typeable import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Evidence -import GHC.Tc.Utils.Instantiate( instDFunType ) import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst ) import GHC.Rename.Env( addUsedGRE ) diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 94582b00a9..40a59f965d 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -2852,7 +2852,7 @@ loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM () -- This is so that we can accurately report the instances for -- something loadUnqualIfaces hsc_env ictxt - = initIfaceTcRn $ do + = initIfaceTcRn $ mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods)) where home_unit = hsc_home_unit hsc_env @@ -3044,7 +3044,7 @@ withTcPlugins hsc_env m = (solvers,stops) <- unzip `fmap` mapM (startPlugin ev_binds_var) plugins -- This ensures that tcPluginStop is called even if a type -- error occurs during compilation (Fix of #10078) - eitherRes <- tryM $ do + eitherRes <- tryM $ updGblEnv (\e -> e { tcg_tc_plugins = solvers }) m mapM_ (flip runTcPluginM ev_binds_var) stops case eitherRes of @@ -3066,7 +3066,7 @@ withHoleFitPlugins hsc_env m = plugins -> do (plugins,stops) <- unzip `fmap` mapM startPlugin plugins -- This ensures that hfPluginStop is called even if a type -- error occurs during compilation. - eitherRes <- tryM $ do + eitherRes <- tryM $ updGblEnv (\e -> e { tcg_hf_plugins = plugins }) m sequence_ stops case eitherRes of diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs index 7f4bcdf871..bf7e9b239e 100644 --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -1831,7 +1831,6 @@ solveImplication imp@(Implic { ic_tclvl = tclvl ; return (floated_eqs, res_implic) } - where -- TcLevels must be strictly increasing (see (ImplicInv) in -- Note [TcLevel and untouchable type variables] in GHC.Tc.Utils.TcType), -- and in fact I think they should always increase one level at a time. @@ -2245,8 +2244,6 @@ approximateWC float_past_equalities wc float_wc trapping_tvs (WC { wc_simple = simples, wc_impl = implics }) = filterBag (is_floatable trapping_tvs) simples `unionBags` concatMapBag (float_implic trapping_tvs) implics - where - float_implic :: TcTyCoVarSet -> Implication -> Cts float_implic trapping_tvs imp | float_past_equalities || ic_no_eqs imp diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs index ad276aa5d2..baa132c2b6 100644 --- a/compiler/GHC/Tc/Solver/Interact.hs +++ b/compiler/GHC/Tc/Solver/Interact.hs @@ -15,23 +15,21 @@ import GHC.Types.Basic ( SwapFlag(..), isSwapped, infinity, IntWithInf, intGtLimit ) import GHC.Tc.Solver.Canonical import GHC.Tc.Solver.Flatten -import GHC.Tc.Utils.Unify( canSolveByUnification ) +import GHC.Tc.Utils.Unify ( canSolveByUnification ) import GHC.Types.Var.Set import GHC.Core.Type as Type import GHC.Core.Coercion ( BlockSubstFlag(..) ) import GHC.Core.InstEnv ( DFunInstType ) -import GHC.Core.Coercion.Axiom ( sfInteractTop, sfInteractInert ) import GHC.Types.Var import GHC.Tc.Utils.TcType -import GHC.Builtin.Names ( coercibleTyConKey, - heqTyConKey, eqTyConKey, ipClassKey ) -import GHC.Core.Coercion.Axiom ( TypeEqn, CoAxiom(..), CoAxBranch(..), fromBranches ) +import GHC.Builtin.Names ( coercibleTyConKey, heqTyConKey, eqTyConKey, ipClassKey ) +import GHC.Core.Coercion.Axiom ( CoAxBranch (..), CoAxiom (..), TypeEqn, fromBranches, sfInteractInert, sfInteractTop ) import GHC.Core.Class import GHC.Core.TyCon import GHC.Tc.Instance.FunDeps import GHC.Tc.Instance.Family -import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap ) +import GHC.Tc.Instance.Class ( InstanceWhat(..), safeOverlap ) import GHC.Core.FamInstEnv import GHC.Core.Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX ) diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs index 1d8ccb7933..311eadc72e 100644 --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -3616,8 +3616,7 @@ emitNewDerivedEq loc role ty1 ty2 newDerivedNC :: CtLoc -> TcPredType -> TcS CtEvidence newDerivedNC loc pred - = do { -- checkReductionDepth loc pred - ; return (CtDerived { ctev_pred = pred, ctev_loc = loc }) } + = return $ CtDerived { ctev_pred = pred, ctev_loc = loc } -- --------- Check done in GHC.Tc.Solver.Interact.selectNewWorkItem???? --------- -- | Checks if the depth of the given location is too much. Fails if diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index e470b21ce6..014a5027a4 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -813,7 +813,6 @@ mkPatSynBuilderId dir (L _ name) builder_id' = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id ; return (Just (builder_id', need_dummy_arg)) } - where tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc) diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs index 8755fbf762..b9fb54cc9f 100644 --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -201,7 +201,7 @@ checkTyConIsAcyclic tc m = SynCycleM $ \s -> -- the corresponding @LTyClDecl Name@ for each 'TyCon', so we -- can give better error messages. checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM () -checkSynCycles this_uid tcs tyclds = do +checkSynCycles this_uid tcs tyclds = case runSynCycleM (mapM_ (go emptyTyConSet []) tcs) emptyTyConSet of Left (loc, err) -> setSrcSpan loc $ failWithTc err Right _ -> return () @@ -775,8 +775,7 @@ addTyConsToGblEnv tyclss do { traceTc "tcAddTyCons" $ vcat [ text "tycons" <+> ppr tyclss , text "implicits" <+> ppr implicit_things ] - ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss) - ; return gbl_env } + ; tcRecSelBinds (mkRecSelBinds tyclss) } where implicit_things = concatMap implicitTyConThings tyclss def_meth_ids = mkDefaultMethodIds tyclss diff --git a/compiler/GHC/Tc/Types/Evidence.hs b/compiler/GHC/Tc/Types/Evidence.hs index f44f10b3a6..127723d4f7 100644 --- a/compiler/GHC/Tc/Types/Evidence.hs +++ b/compiler/GHC/Tc/Types/Evidence.hs @@ -69,8 +69,7 @@ import GHC.Core.Ppr () -- Instance OutputableBndr TyVar import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.TyCon -import GHC.Core.DataCon( DataCon, dataConWrapId ) -import GHC.Core.Class( Class ) +import GHC.Core.DataCon ( DataCon, dataConWrapId ) import GHC.Builtin.Names import GHC.Types.Var.Env import GHC.Types.Var.Set @@ -79,7 +78,7 @@ import GHC.Types.Name import GHC.Data.Pair import GHC.Core -import GHC.Core.Class ( classSCSelId ) +import GHC.Core.Class (Class, classSCSelId ) import GHC.Core.FVs ( exprSomeFreeVars ) import GHC.Utils.Misc diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index 7755d3370d..61d0cdcd47 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -520,14 +520,15 @@ tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r tcExtendNameTyVarEnv binds thing_inside -- this should be used only for explicitly mentioned scoped variables. -- thus, no coercion variables - = do { tc_extend_local_env NotTopLevel - [(name, ATyVar name tv) | (name, tv) <- binds] $ - tcExtendBinderStack tv_binds $ - thing_inside } + = tc_extend_local_env NotTopLevel names $ + tcExtendBinderStack tv_binds $ + thing_inside where tv_binds :: [TcBinder] tv_binds = [TcTvBndr name tv | (name,tv) <- binds] + names = [(name, ATyVar name tv) | (name, tv) <- binds] + isTypeClosedLetBndr :: Id -> Bool -- See Note [Bindings with closed types] in GHC.Tc.Types isTypeClosedLetBndr = noFreeVarsOfType . idType diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs index 5416e29692..6940d161d6 100644 --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -11,31 +11,31 @@ -} module GHC.Tc.Utils.Instantiate ( - topSkolemise, - topInstantiate, instantiateSigma, - instCall, instDFunType, instStupidTheta, instTyVarsWith, - newWanted, newWanteds, + topSkolemise, + topInstantiate, instantiateSigma, + instCall, instDFunType, instStupidTheta, instTyVarsWith, + newWanted, newWanteds, - tcInstType, tcInstTypeBndrs, - tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt, - tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX, + tcInstType, tcInstTypeBndrs, + tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt, + tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX, - freshenTyVarBndrs, freshenCoVarBndrsX, + freshenTyVarBndrs, freshenCoVarBndrsX, - tcInstInvisibleTyBindersN, tcInstInvisibleTyBinders, tcInstInvisibleTyBinder, + tcInstInvisibleTyBindersN, tcInstInvisibleTyBinders, tcInstInvisibleTyBinder, - newOverloadedLit, mkOverLit, + newOverloadedLit, mkOverLit, - newClsInst, - tcGetInsts, tcGetInstEnvs, getOverlapFlag, - tcExtendLocalInstEnv, - instCallConstraints, newMethodFromName, - tcSyntaxName, + newClsInst, + tcGetInsts, tcGetInstEnvs, getOverlapFlag, + tcExtendLocalInstEnv, + instCallConstraints, newMethodFromName, + tcSyntaxName, - -- Simple functions over evidence variables - tyCoVarsOfWC, - tyCoVarsOfCt, tyCoVarsOfCts, - ) where + -- Simple functions over evidence variables + tyCoVarsOfWC, + tyCoVarsOfCt, tyCoVarsOfCts, + ) where #include "HsVersions.h" @@ -50,13 +50,12 @@ import GHC.Hs import GHC.Core.InstEnv import GHC.Core.Predicate -import GHC.Core ( isOrphan ) +import GHC.Core ( Expr(..), isOrphan ) -- For the Coercion constructor import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr ( debugPprType ) import GHC.Core.Class( Class ) -import GHC.Core( Expr(..) ) -- For the Coercion constructor import GHC.Core.DataCon import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckPolyExpr, tcSyntaxOp ) diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index e42fe42799..a040cca093 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -746,14 +746,14 @@ formatTraceMsg :: String -> SDoc -> SDoc formatTraceMsg herald doc = hang (text herald) 2 doc traceOptTcRn :: DumpFlag -> SDoc -> TcRn () -traceOptTcRn flag doc = do +traceOptTcRn flag doc = whenDOptM flag $ dumpTcRn False (dumpOptionsFromFlag flag) "" FormatText doc {-# INLINE traceOptTcRn #-} -- see Note [INLINE conditional tracing utilities] -- | Dump if the given 'DumpFlag' is set. dumpOptTcRn :: DumpFlag -> String -> DumpFormat -> SDoc -> TcRn () -dumpOptTcRn flag title fmt doc = do +dumpOptTcRn flag title fmt doc = whenDOptM flag $ dumpTcRn False (dumpOptionsFromFlag flag) title fmt doc {-# INLINE dumpOptTcRn #-} -- see Note [INLINE conditional tracing utilities] @@ -2053,43 +2053,43 @@ failIfM msg ; failM } -------------------- -forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a) --- Run thing_inside in an interleaved thread. + +-- | Run thing_inside in an interleaved thread. -- It shares everything with the parent thread, so this is DANGEROUS. -- -- It returns Nothing if the computation fails -- -- It's used for lazily type-checking interface --- signatures, which is pretty benign - +-- signatures, which is pretty benign. +-- +-- See Note [Masking exceptions in forkM_maybe] +forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a) forkM_maybe doc thing_inside - = do { -- see Note [Masking exceptions in forkM_maybe] - ; unsafeInterleaveM $ uninterruptibleMaskM_ $ - do { traceIf (text "Starting fork {" <+> doc) - ; mb_res <- tryM $ - updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $ - thing_inside - ; case mb_res of - Right r -> do { traceIf (text "} ending fork" <+> doc) - ; return (Just r) } - Left exn -> do { - - -- Bleat about errors in the forked thread, if -ddump-if-trace is on - -- Otherwise we silently discard errors. Errors can legitimately - -- happen when compiling interface signatures (see tcInterfaceSigs) - whenDOptM Opt_D_dump_if_trace $ do - dflags <- getDynFlags - let msg = hang (text "forkM failed:" <+> doc) - 2 (text (show exn)) - liftIO $ putLogMsg dflags - NoReason - SevFatal - noSrcSpan - $ withPprStyle defaultErrStyle msg - - ; traceIf (text "} ending fork (badly)" <+> doc) - ; return Nothing } - }} + = unsafeInterleaveM $ uninterruptibleMaskM_ $ + do { traceIf (text "Starting fork {" <+> doc) + ; mb_res <- tryM $ + updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $ + thing_inside + ; case mb_res of + Right r -> do { traceIf (text "} ending fork" <+> doc) + ; return (Just r) } + Left exn -> do { + -- Bleat about errors in the forked thread, if -ddump-if-trace is on + -- Otherwise we silently discard errors. Errors can legitimately + -- happen when compiling interface signatures (see tcInterfaceSigs) + whenDOptM Opt_D_dump_if_trace $ do + dflags <- getDynFlags + let msg = hang (text "forkM failed:" <+> doc) + 2 (text (show exn)) + liftIO $ putLogMsg dflags + NoReason + SevFatal + noSrcSpan + $ withPprStyle defaultErrStyle msg + + ; traceIf (text "} ending fork (badly)" <+> doc) + ; return Nothing } + } forkM :: SDoc -> IfL a -> IfL a forkM doc thing_inside diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 0130989940..26325cf7bc 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -1019,7 +1019,7 @@ cvtl e = wrapL (cvt e) -- constructor names - see #14627. { s' <- vcName s ; return $ HsVar noExtField (noLoc s') } - cvt (LabelE s) = do { return $ HsOverLabel noExtField Nothing (fsLit s) } + cvt (LabelE s) = return $ HsOverLabel noExtField Nothing (fsLit s) cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExtField n' } {- | #16895 Ensure an infix expression's operator is a variable/constructor. @@ -1497,7 +1497,7 @@ cvtTypeKind ty_str ty tys' ListT | Just normals <- m_normals - , [x'] <- normals -> do + , [x'] <- normals -> returnL (HsListTy noExtField x') | otherwise -> mk_apps @@ -1584,8 +1584,7 @@ cvtTypeKind ty_str ty -- in Language.Haskell.TH.Syntax | Just normals <- m_normals , [ty1, L _ (HsExplicitListTy _ ip tys2)] <- normals - -> do - returnL (HsExplicitListTy noExtField ip (ty1:tys2)) + -> returnL (HsExplicitListTy noExtField ip (ty1:tys2)) | otherwise -> mk_apps (HsTyVar noExtField IsPromoted (noLoc (getRdrName consDataCon))) diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index 0f6f728da6..3b2f1a3140 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -525,15 +525,15 @@ instance Outputable RecFlag where ppr NonRecursive = text "NonRecursive" instance Binary RecFlag where - put_ bh Recursive = do + put_ bh Recursive = putByte bh 0 - put_ bh NonRecursive = do + put_ bh NonRecursive = putByte bh 1 get bh = do h <- getByte bh case h of - 0 -> do return Recursive - _ -> do return NonRecursive + 0 -> return Recursive + _ -> return NonRecursive {- ************************************************************************ @@ -819,9 +819,9 @@ instance Binary TupleSort where get bh = do h <- getByte bh case h of - 0 -> do return BoxedTuple - 1 -> do return UnboxedTuple - _ -> do return ConstraintTuple + 0 -> return BoxedTuple + 1 -> return UnboxedTuple + _ -> return ConstraintTuple tupleSortBoxity :: TupleSort -> Boxity @@ -1483,11 +1483,11 @@ instance Outputable Activation where ppr FinalActive = text "[final]" instance Binary Activation where - put_ bh NeverActive = do + put_ bh NeverActive = putByte bh 0 - put_ bh FinalActive = do + put_ bh FinalActive = putByte bh 1 - put_ bh AlwaysActive = do + put_ bh AlwaysActive = putByte bh 2 put_ bh (ActiveBefore src aa) = do putByte bh 3 @@ -1500,9 +1500,9 @@ instance Binary Activation where get bh = do h <- getByte bh case h of - 0 -> do return NeverActive - 1 -> do return FinalActive - 2 -> do return AlwaysActive + 0 -> return NeverActive + 1 -> return FinalActive + 2 -> return AlwaysActive 3 -> do src <- get bh aa <- get bh return (ActiveBefore src aa) diff --git a/compiler/GHC/Types/CostCentre.hs b/compiler/GHC/Types/CostCentre.hs index 0bb615a1c4..61f6b87c88 100644 --- a/compiler/GHC/Types/CostCentre.hs +++ b/compiler/GHC/Types/CostCentre.hs @@ -317,7 +317,7 @@ costCentreSrcSpan :: CostCentre -> SrcSpan costCentreSrcSpan = cc_loc instance Binary CCFlavour where - put_ bh CafCC = do + put_ bh CafCC = putByte bh 0 put_ bh (ExprCC i) = do putByte bh 1 @@ -331,10 +331,10 @@ instance Binary CCFlavour where get bh = do h <- getByte bh case h of - 0 -> do return CafCC + 0 -> return CafCC 1 -> ExprCC <$> get bh 2 -> DeclCC <$> get bh - _ -> HpcCC <$> get bh + _ -> HpcCC <$> get bh instance Binary CostCentre where put_ bh (NormalCC aa ab ac _ad) = do diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index b01bb8f444..f84e3c0bc2 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -1950,8 +1950,8 @@ out how deeply we can unpack x, or that we do not have to pass y. -} instance Binary StrDmd where - put_ bh HyperStr = do putByte bh 0 - put_ bh HeadStr = do putByte bh 1 + put_ bh HyperStr = putByte bh 0 + put_ bh HeadStr = putByte bh 1 put_ bh (SCall s) = do putByte bh 2 put_ bh s put_ bh (SProd sx) = do putByte bh 3 @@ -1959,17 +1959,17 @@ instance Binary StrDmd where get bh = do h <- getByte bh case h of - 0 -> do return HyperStr - 1 -> do return HeadStr + 0 -> return HyperStr + 1 -> return HeadStr 2 -> do s <- get bh return (SCall s) _ -> do sx <- get bh return (SProd sx) instance Binary ArgStr where - put_ bh Lazy = do + put_ bh Lazy = putByte bh 0 - put_ bh (Str s) = do + put_ bh (Str s) = do putByte bh 1 put_ bh s @@ -1981,8 +1981,8 @@ instance Binary ArgStr where return $ Str s instance Binary Count where - put_ bh One = do putByte bh 0 - put_ bh Many = do putByte bh 1 + put_ bh One = putByte bh 0 + put_ bh Many = putByte bh 1 get bh = do h <- getByte bh case h of @@ -1990,9 +1990,9 @@ instance Binary Count where _ -> return Many instance Binary ArgUse where - put_ bh Abs = do + put_ bh Abs = putByte bh 0 - put_ bh (Use c u) = do + put_ bh (Use c u) = do putByte bh 1 put_ bh c put_ bh u @@ -2001,16 +2001,14 @@ instance Binary ArgUse where h <- getByte bh case h of 0 -> return Abs - _ -> do c <- get bh - u <- get bh - return $ Use c u + _ -> Use <$> get bh <*> get bh instance Binary UseDmd where - put_ bh Used = do + put_ bh Used = putByte bh 0 - put_ bh UHead = do + put_ bh UHead = putByte bh 1 - put_ bh (UCall c u) = do + put_ bh (UCall c u) = do putByte bh 2 put_ bh c put_ bh u @@ -2031,17 +2029,11 @@ instance Binary UseDmd where instance (Binary s, Binary u) => Binary (JointDmd s u) where put_ bh (JD { sd = x, ud = y }) = do put_ bh x; put_ bh y - get bh = do - x <- get bh - y <- get bh - return $ JD { sd = x, ud = y } + get bh = JD <$> get bh <*> get bh instance Binary StrictSig where - put_ bh (StrictSig aa) = do - put_ bh aa - get bh = do - aa <- get bh - return (StrictSig aa) + put_ bh (StrictSig aa) = put_ bh aa + get bh = StrictSig <$> get bh instance Binary DmdType where -- Ignore DmdEnv when spitting out the DmdType diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs index 52fe3837b7..cb624c6c99 100644 --- a/compiler/GHC/Types/Error.hs +++ b/compiler/GHC/Types/Error.hs @@ -159,9 +159,8 @@ getSeverityColour _ = const mempty getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty -getCaretDiagnostic severity (RealSrcSpan span _) = do +getCaretDiagnostic severity (RealSrcSpan span _) = caretDiagnostic <$> getSrcLine (srcSpanFile span) row - where getSrcLine fn i = getLine i (unpackFS fn) diff --git a/compiler/GHC/Types/Fixity.hs b/compiler/GHC/Types/Fixity.hs index fb8807ab9d..1eca7592c5 100644 --- a/compiler/GHC/Types/Fixity.hs +++ b/compiler/GHC/Types/Fixity.hs @@ -57,18 +57,18 @@ instance Outputable FixityDirection where ppr InfixN = text "infix" instance Binary FixityDirection where - put_ bh InfixL = do + put_ bh InfixL = putByte bh 0 - put_ bh InfixR = do + put_ bh InfixR = putByte bh 1 - put_ bh InfixN = do + put_ bh InfixN = putByte bh 2 get bh = do h <- getByte bh case h of - 0 -> do return InfixL - 1 -> do return InfixR - _ -> do return InfixN + 0 -> return InfixL + 1 -> return InfixR + _ -> return InfixN ------------------------ maxPrecedence, minPrecedence :: Int diff --git a/compiler/GHC/Types/ForeignCall.hs b/compiler/GHC/Types/ForeignCall.hs index bf10a9a197..0951016524 100644 --- a/compiler/GHC/Types/ForeignCall.hs +++ b/compiler/GHC/Types/ForeignCall.hs @@ -266,18 +266,18 @@ instance Binary ForeignCall where get bh = do aa <- get bh; return (CCall aa) instance Binary Safety where - put_ bh PlaySafe = do + put_ bh PlaySafe = putByte bh 0 - put_ bh PlayInterruptible = do + put_ bh PlayInterruptible = putByte bh 1 - put_ bh PlayRisky = do + put_ bh PlayRisky = putByte bh 2 get bh = do h <- getByte bh case h of - 0 -> do return PlaySafe - 1 -> do return PlayInterruptible - _ -> do return PlayRisky + 0 -> return PlaySafe + 1 -> return PlayInterruptible + _ -> return PlayRisky instance Binary CExportSpec where put_ bh (CExportStatic ss aa ab) = do @@ -308,7 +308,7 @@ instance Binary CCallTarget where put_ bh aa put_ bh ab put_ bh ac - put_ bh DynamicTarget = do + put_ bh DynamicTarget = putByte bh 1 get bh = do h <- getByte bh @@ -318,27 +318,27 @@ instance Binary CCallTarget where ab <- get bh ac <- get bh return (StaticTarget ss aa ab ac) - _ -> do return DynamicTarget + _ -> return DynamicTarget instance Binary CCallConv where - put_ bh CCallConv = do + put_ bh CCallConv = putByte bh 0 - put_ bh StdCallConv = do + put_ bh StdCallConv = putByte bh 1 - put_ bh PrimCallConv = do + put_ bh PrimCallConv = putByte bh 2 - put_ bh CApiConv = do + put_ bh CApiConv = putByte bh 3 - put_ bh JavaScriptCallConv = do + put_ bh JavaScriptCallConv = putByte bh 4 get bh = do h <- getByte bh case h of - 0 -> do return CCallConv - 1 -> do return StdCallConv - 2 -> do return PrimCallConv - 3 -> do return CApiConv - _ -> do return JavaScriptCallConv + 0 -> return CCallConv + 1 -> return StdCallConv + 2 -> return PrimCallConv + 3 -> return CApiConv + _ -> return JavaScriptCallConv instance Binary CType where put_ bh (CType s mh fs) = do put_ bh s diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs index 6fea5e2fdb..461f4ac70a 100644 --- a/compiler/GHC/Types/Literal.hs +++ b/compiler/GHC/Types/Literal.hs @@ -207,7 +207,7 @@ instance Binary LitNumType where instance Binary Literal where put_ bh (LitChar aa) = do putByte bh 0; put_ bh aa put_ bh (LitString ab) = do putByte bh 1; put_ bh ab - put_ bh (LitNullAddr) = do putByte bh 2 + put_ bh (LitNullAddr) = putByte bh 2 put_ bh (LitFloat ah) = do putByte bh 3; put_ bh ah put_ bh (LitDouble ai) = do putByte bh 4; put_ bh ai put_ bh (LitLabel aj mb fod) @@ -219,7 +219,7 @@ instance Binary Literal where = do putByte bh 6 put_ bh nt put_ bh i - put_ bh (LitRubbish) = do putByte bh 7 + put_ bh (LitRubbish) = putByte bh 7 get bh = do h <- getByte bh case h of @@ -229,8 +229,7 @@ instance Binary Literal where 1 -> do ab <- get bh return (LitString ab) - 2 -> do - return (LitNullAddr) + 2 -> return (LitNullAddr) 3 -> do ah <- get bh return (LitFloat ah) @@ -246,8 +245,7 @@ instance Binary Literal where nt <- get bh i <- get bh return (LitNumber nt i) - _ -> do - return (LitRubbish) + _ -> return (LitRubbish) instance Outputable Literal where ppr = pprLiteral id diff --git a/compiler/GHC/Types/Name/Occurrence.hs b/compiler/GHC/Types/Name/Occurrence.hs index b3d3b0855d..d2e4127010 100644 --- a/compiler/GHC/Types/Name/Occurrence.hs +++ b/compiler/GHC/Types/Name/Occurrence.hs @@ -906,21 +906,21 @@ tidyOccName env occ@(OccName occ_sp fs) -} instance Binary NameSpace where - put_ bh VarName = do + put_ bh VarName = putByte bh 0 - put_ bh DataName = do + put_ bh DataName = putByte bh 1 - put_ bh TvName = do + put_ bh TvName = putByte bh 2 - put_ bh TcClsName = do + put_ bh TcClsName = putByte bh 3 get bh = do h <- getByte bh case h of - 0 -> do return VarName - 1 -> do return DataName - 2 -> do return TvName - _ -> do return TcClsName + 0 -> return VarName + 1 -> return DataName + 2 -> return TvName + _ -> return TcClsName instance Binary OccName where put_ bh (OccName aa ab) = do diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs index d1a071dd93..0e6c9ead94 100644 --- a/compiler/GHC/Types/Name/Reader.hs +++ b/compiler/GHC/Types/Name/Reader.hs @@ -959,18 +959,17 @@ pickGREsModExp :: ModuleName -> [GlobalRdrElt] -> [(GlobalRdrElt,GlobalRdrElt)] -- see 'GHC.Tc.Gen.Export.exports_from_avail' pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres +-- | isBuiltInSyntax filter out names for built-in syntax They +-- just clutter up the environment (esp tuples), and the +-- parser will generate Exact RdrNames for them, so the +-- cluttered envt is no use. Really, it's only useful for +-- GHC.Base and GHC.Tuple. pickBothGRE :: ModuleName -> GlobalRdrElt -> Maybe (GlobalRdrElt, GlobalRdrElt) pickBothGRE mod gre@(GRE { gre_name = n }) | isBuiltInSyntax n = Nothing | Just gre1 <- pickQualGRE mod gre , Just gre2 <- pickUnqualGRE gre = Just (gre1, gre2) | otherwise = Nothing - where - -- isBuiltInSyntax filter out names for built-in syntax They - -- just clutter up the environment (esp tuples), and the - -- parser will generate Exact RdrNames for them, so the - -- cluttered envt is no use. Really, it's only useful for - -- GHC.Base and GHC.Tuple. -- Building GlobalRdrEnvs diff --git a/compiler/GHC/Unit/Finder.hs b/compiler/GHC/Unit/Finder.hs index da5c589024..5f038f5d83 100644 --- a/compiler/GHC/Unit/Finder.hs +++ b/compiler/GHC/Unit/Finder.hs @@ -407,28 +407,16 @@ findPackageModule_ hsc_env mod pkg_conf = -- ----------------------------------------------------------------------------- -- General path searching -searchPathExts - :: [FilePath] -- paths to search - -> InstalledModule -- module name - -> [ ( - FileExt, -- suffix - FilePath -> BaseName -> IO ModLocation -- action - ) - ] - -> IO InstalledFindResult - -searchPathExts paths mod exts - = do result <- search to_search -{- - hPutStrLn stderr (showSDoc $ - vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts) - , nest 2 (vcat (map text paths)) - , case result of - Succeeded (loc, p) -> text "Found" <+> ppr loc - Failed fs -> text "not found"]) --} - return result - +searchPathExts :: [FilePath] -- paths to search + -> InstalledModule -- module name + -> [ ( + FileExt, -- suffix + FilePath -> BaseName -> IO ModLocation -- action + ) + ] + -> IO InstalledFindResult + +searchPathExts paths mod exts = search to_search where basename = moduleNameSlashes (moduleName mod) @@ -451,8 +439,8 @@ searchPathExts paths mod exts mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt -> FilePath -> BaseName -> IO ModLocation -mkHomeModLocationSearched dflags mod suff path basename = do - mkHomeModLocation2 dflags mod (path </> basename) suff +mkHomeModLocationSearched dflags mod suff path basename = + mkHomeModLocation2 dflags mod (path </> basename) suff -- ----------------------------------------------------------------------------- -- Constructing a home module location diff --git a/compiler/GHC/Unit/Module/ModIface.hs b/compiler/GHC/Unit/Module/ModIface.hs index 83bc565b6f..b7e0235730 100644 --- a/compiler/GHC/Unit/Module/ModIface.hs +++ b/compiler/GHC/Unit/Module/ModIface.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} module GHC.Unit.Module.ModIface diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs index 78f96c90f3..1d770de9f1 100644 --- a/compiler/GHC/Unit/State.hs +++ b/compiler/GHC/Unit/State.hs @@ -715,7 +715,7 @@ readUnitDatabase printer cfg conf_file = do <+> text conf_dir <> text ", treating" <+> text "package database as empty" return [] - else do + else throwGhcExceptionIO $ InstallationError $ "there is no package.cache in " ++ conf_dir ++ " even though package database is not empty" diff --git a/compiler/GHC/Unit/Types.hs b/compiler/GHC/Unit/Types.hs index aa725b429c..b2f3ce0c50 100644 --- a/compiler/GHC/Unit/Types.hs +++ b/compiler/GHC/Unit/Types.hs @@ -349,7 +349,7 @@ instance Binary Unit where put_ bh (VirtUnit indef_uid) = do putByte bh 1 put_ bh indef_uid - put_ bh HoleUnit = do + put_ bh HoleUnit = putByte bh 2 get bh = do b <- getByte bh case b of diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs index dbc2cdc195..1579eeb5a8 100644 --- a/compiler/GHC/Utils/Binary.hs +++ b/compiler/GHC/Utils/Binary.hs @@ -3,7 +3,6 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index 2db4672f07..25da8be3de 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -1,6 +1,5 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {- @@ -124,10 +123,6 @@ orValid IsValid _ = IsValid orValid _ v = v -- ----------------------------------------------------------------------------- --- Basic error messages: just render a message with a source location. - - --- ----------------------------------------------------------------------------- -- Collecting up messages for later ordering and printing. mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg @@ -536,42 +531,42 @@ withTiming' :: MonadIO m -> m a -- ^ The body of the phase to be timed -> m a withTiming' dflags what force_result prtimings action - = do if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags - then do whenPrintTimings $ - logInfo dflags $ withPprStyle defaultUserStyle $ - text "***" <+> what <> colon - let ctx = initDefaultSDocContext dflags - eventBegins ctx what - alloc0 <- liftIO getAllocationCounter - start <- liftIO getCPUTime - !r <- action - () <- pure $ force_result r - eventEnds ctx what - end <- liftIO getCPUTime - alloc1 <- liftIO getAllocationCounter - -- recall that allocation counter counts down - let alloc = alloc0 - alloc1 - time = realToFrac (end - start) * 1e-9 - - when (verbosity dflags >= 2 && prtimings == PrintTimings) - $ liftIO $ logInfo dflags $ withPprStyle defaultUserStyle - (text "!!!" <+> what <> colon <+> text "finished in" - <+> doublePrec 2 time - <+> text "milliseconds" - <> comma - <+> text "allocated" - <+> doublePrec 3 (realToFrac alloc / 1024 / 1024) - <+> text "megabytes") - - whenPrintTimings $ - dumpIfSet_dyn dflags Opt_D_dump_timings "" FormatText - $ text $ showSDocOneLine ctx - $ hsep [ what <> colon - , text "alloc=" <> ppr alloc - , text "time=" <> doublePrec 3 time - ] - pure r - else action + = if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags + then do whenPrintTimings $ + logInfo dflags $ withPprStyle defaultUserStyle $ + text "***" <+> what <> colon + let ctx = initDefaultSDocContext dflags + eventBegins ctx what + alloc0 <- liftIO getAllocationCounter + start <- liftIO getCPUTime + !r <- action + () <- pure $ force_result r + eventEnds ctx what + end <- liftIO getCPUTime + alloc1 <- liftIO getAllocationCounter + -- recall that allocation counter counts down + let alloc = alloc0 - alloc1 + time = realToFrac (end - start) * 1e-9 + + when (verbosity dflags >= 2 && prtimings == PrintTimings) + $ liftIO $ logInfo dflags $ withPprStyle defaultUserStyle + (text "!!!" <+> what <> colon <+> text "finished in" + <+> doublePrec 2 time + <+> text "milliseconds" + <> comma + <+> text "allocated" + <+> doublePrec 3 (realToFrac alloc / 1024 / 1024) + <+> text "megabytes") + + whenPrintTimings $ + dumpIfSet_dyn dflags Opt_D_dump_timings "" FormatText + $ text $ showSDocOneLine ctx + $ hsep [ what <> colon + , text "alloc=" <> ppr alloc + , text "time=" <> doublePrec 3 time + ] + pure r + else action where whenPrintTimings = liftIO . when (prtimings == PrintTimings) eventBegins ctx w = do @@ -776,8 +771,8 @@ type TraceAction = forall a. DynFlags -> String -> SDoc -> a -> a -- | Default action for 'dumpAction' hook defaultDumpAction :: DumpAction -defaultDumpAction dflags sty dumpOpt title _fmt doc = do - dumpSDocWithStyle sty dflags dumpOpt title doc +defaultDumpAction dflags sty dumpOpt title _fmt doc = + dumpSDocWithStyle sty dflags dumpOpt title doc -- | Default action for 'traceAction' hook defaultTraceAction :: TraceAction diff --git a/compiler/GHC/Utils/Exception.hs b/compiler/GHC/Utils/Exception.hs index 49fa19bd47..46c1f9d37d 100644 --- a/compiler/GHC/Utils/Exception.hs +++ b/compiler/GHC/Utils/Exception.hs @@ -3,14 +3,13 @@ module GHC.Utils.Exception ( - module Control.Exception, + module CE, module GHC.Utils.Exception ) where import GHC.Prelude -import Control.Exception import Control.Exception as CE import Control.Monad.IO.Class import Control.Monad.Catch diff --git a/compiler/GHC/Utils/GlobalVars.hs b/compiler/GHC/Utils/GlobalVars.hs index 5556a7e4f1..f169d07161 100644 --- a/compiler/GHC/Utils/GlobalVars.hs +++ b/compiler/GHC/Utils/GlobalVars.hs @@ -95,7 +95,7 @@ global :: a -> IORef a global a = unsafePerformIO (newIORef a) consIORef :: IORef [a] -> a -> IO () -consIORef var x = do +consIORef var x = atomicModifyIORef' var (\xs -> (x:xs,())) globalM :: IO a -> IORef a diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs index 7436487739..07d4b721ff 100644 --- a/compiler/GHC/Utils/Misc.hs +++ b/compiler/GHC/Utils/Misc.hs @@ -1281,7 +1281,7 @@ getModificationUTCTime = getModificationTime -- check existence & modification time at the same time modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime) -modificationTimeIfExists f = do +modificationTimeIfExists f = (do t <- getModificationUTCTime f; return (Just t)) `catchIO` \e -> if isDoesNotExistError e then return Nothing |