summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorHécate <hecate+gitlab@glitchbra.in>2020-10-10 21:15:36 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-11-01 01:11:09 -0400
commitdfd27445308d1ed2df8826c2a045130e918e8192 (patch)
tree99fc01edeebc2924ddb7533864e0d4ca18cfe800 /compiler
parentbd4abdc953427e084e7ecba89db64860f6859822 (diff)
downloadhaskell-dfd27445308d1ed2df8826c2a045130e918e8192.tar.gz
Add the proper HLint rules and remove redundant keywords from compiler
Diffstat (limited to 'compiler')
-rw-r--r--compiler/.hlint.yaml17
-rw-r--r--compiler/GHC/Cmm/Graph.hs10
-rw-r--r--compiler/GHC/Cmm/LayoutStack.hs41
-rw-r--r--compiler/GHC/Cmm/Pipeline.hs176
-rw-r--r--compiler/GHC/Cmm/ProcPoint.hs298
-rw-r--r--compiler/GHC/CmmToAsm.hs32
-rw-r--r--compiler/GHC/CmmToAsm/BlockLayout.hs12
-rw-r--r--compiler/GHC/CmmToAsm/CFG/Dominators.hs7
-rw-r--r--compiler/GHC/CmmToAsm/PPC/CodeGen.hs16
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs77
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/CodeGen.hs8
-rw-r--r--compiler/GHC/CmmToAsm/X86/CodeGen.hs41
-rw-r--r--compiler/GHC/CmmToLlvm/CodeGen.hs30
-rw-r--r--compiler/GHC/Core/Lint.hs4
-rw-r--r--compiler/GHC/Core/Opt/ConstantFold.hs5
-rw-r--r--compiler/GHC/Core/Opt/Exitify.hs2
-rw-r--r--compiler/GHC/Core/Opt/Monad.hs3
-rw-r--r--compiler/GHC/Core/Opt/Pipeline.hs2
-rw-r--r--compiler/GHC/Core/Opt/Simplify.hs20
-rw-r--r--compiler/GHC/Core/Opt/SpecConstr.hs8
-rw-r--r--compiler/GHC/Core/Opt/Specialise.hs8
-rw-r--r--compiler/GHC/Core/Opt/StaticArgs.hs6
-rw-r--r--compiler/GHC/Core/TyCon/Env.hs4
-rw-r--r--compiler/GHC/Core/TyCon/RecWalk.hs2
-rw-r--r--compiler/GHC/Core/TyCon/Set.hs2
-rw-r--r--compiler/GHC/Core/Utils.hs3
-rw-r--r--compiler/GHC/CoreToStg.hs23
-rw-r--r--compiler/GHC/Data/FastString.hs10
-rw-r--r--compiler/GHC/Data/StringBuffer.hs16
-rw-r--r--compiler/GHC/Driver/Backpack.hs20
-rw-r--r--compiler/GHC/Driver/CodeOutput.hs47
-rw-r--r--compiler/GHC/Driver/Main.hs17
-rw-r--r--compiler/GHC/Driver/Make.hs2
-rw-r--r--compiler/GHC/Driver/Pipeline.hs82
-rw-r--r--compiler/GHC/Driver/Session.hs4
-rw-r--r--compiler/GHC/Hs/Type.hs4
-rw-r--r--compiler/GHC/HsToCore.hs2
-rw-r--r--compiler/GHC/HsToCore/Coverage.hs38
-rw-r--r--compiler/GHC/HsToCore/Expr.hs46
-rw-r--r--compiler/GHC/HsToCore/Match.hs5
-rw-r--r--compiler/GHC/HsToCore/Match/Literal.hs6
-rw-r--r--compiler/GHC/HsToCore/Pmc.hs8
-rw-r--r--compiler/GHC/HsToCore/Pmc/Desugar.hs7
-rw-r--r--compiler/GHC/HsToCore/Pmc/Solver.hs4
-rw-r--r--compiler/GHC/HsToCore/Quote.hs9
-rw-r--r--compiler/GHC/Iface/Ext/Binary.hs7
-rw-r--r--compiler/GHC/Iface/Ext/Fields.hs2
-rw-r--r--compiler/GHC/Iface/Ext/Utils.hs5
-rw-r--r--compiler/GHC/Iface/Load.hs2
-rw-r--r--compiler/GHC/Iface/Recomp.hs16
-rw-r--r--compiler/GHC/Iface/Recomp/Binary.hs3
-rw-r--r--compiler/GHC/Iface/Rename.hs2
-rw-r--r--compiler/GHC/Iface/Syntax.hs8
-rw-r--r--compiler/GHC/Iface/Type.hs10
-rw-r--r--compiler/GHC/IfaceToCore.hs11
-rw-r--r--compiler/GHC/Parser/Header.hs2
-rw-r--r--compiler/GHC/Parser/PostProcess.hs7
-rw-r--r--compiler/GHC/Rename/Bind.hs18
-rw-r--r--compiler/GHC/Rename/Expr.hs22
-rw-r--r--compiler/GHC/Rename/Module.hs20
-rw-r--r--compiler/GHC/Rename/Names.hs2
-rw-r--r--compiler/GHC/Rename/Splice.hs9
-rw-r--r--compiler/GHC/Rename/Utils.hs4
-rw-r--r--compiler/GHC/Runtime/Eval.hs21
-rw-r--r--compiler/GHC/Runtime/Heap/Inspect.hs2
-rw-r--r--compiler/GHC/Runtime/Interpreter.hs20
-rw-r--r--compiler/GHC/Runtime/Linker.hs8
-rw-r--r--compiler/GHC/Runtime/Loader.hs3
-rw-r--r--compiler/GHC/Stg/Lift.hs4
-rw-r--r--compiler/GHC/StgToCmm/Expr.hs8
-rw-r--r--compiler/GHC/StgToCmm/Heap.hs2
-rw-r--r--compiler/GHC/StgToCmm/Monad.hs2
-rw-r--r--compiler/GHC/StgToCmm/Prim.hs504
-rw-r--r--compiler/GHC/StgToCmm/Prof.hs2
-rw-r--r--compiler/GHC/StgToCmm/Utils.hs4
-rw-r--r--compiler/GHC/SysTools/ExtraObj.hs2
-rw-r--r--compiler/GHC/SysTools/Info.hs151
-rw-r--r--compiler/GHC/SysTools/Process.hs6
-rw-r--r--compiler/GHC/SysTools/Tasks.hs5
-rw-r--r--compiler/GHC/Tc/Deriv.hs3
-rw-r--r--compiler/GHC/Tc/Deriv/Infer.hs3
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs5
-rw-r--r--compiler/GHC/Tc/Gen/HsType.hs4
-rw-r--r--compiler/GHC/Tc/Instance/Class.hs4
-rw-r--r--compiler/GHC/Tc/Module.hs6
-rw-r--r--compiler/GHC/Tc/Solver.hs3
-rw-r--r--compiler/GHC/Tc/Solver/Interact.hs10
-rw-r--r--compiler/GHC/Tc/Solver/Monad.hs3
-rw-r--r--compiler/GHC/Tc/TyCl/PatSyn.hs1
-rw-r--r--compiler/GHC/Tc/TyCl/Utils.hs5
-rw-r--r--compiler/GHC/Tc/Types/Evidence.hs5
-rw-r--r--compiler/GHC/Tc/Utils/Env.hs9
-rw-r--r--compiler/GHC/Tc/Utils/Instantiate.hs41
-rw-r--r--compiler/GHC/Tc/Utils/Monad.hs66
-rw-r--r--compiler/GHC/ThToHs.hs7
-rw-r--r--compiler/GHC/Types/Basic.hs26
-rw-r--r--compiler/GHC/Types/CostCentre.hs6
-rw-r--r--compiler/GHC/Types/Demand.hs42
-rw-r--r--compiler/GHC/Types/Error.hs3
-rw-r--r--compiler/GHC/Types/Fixity.hs12
-rw-r--r--compiler/GHC/Types/ForeignCall.hs36
-rw-r--r--compiler/GHC/Types/Literal.hs10
-rw-r--r--compiler/GHC/Types/Name/Occurrence.hs16
-rw-r--r--compiler/GHC/Types/Name/Reader.hs11
-rw-r--r--compiler/GHC/Unit/Finder.hs36
-rw-r--r--compiler/GHC/Unit/Module/ModIface.hs2
-rw-r--r--compiler/GHC/Unit/State.hs2
-rw-r--r--compiler/GHC/Unit/Types.hs2
-rw-r--r--compiler/GHC/Utils/Binary.hs1
-rw-r--r--compiler/GHC/Utils/Error.hs81
-rw-r--r--compiler/GHC/Utils/Exception.hs3
-rw-r--r--compiler/GHC/Utils/GlobalVars.hs2
-rw-r--r--compiler/GHC/Utils/Misc.hs2
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