ghc-lib 0.20220201 → 0.20220301
raw patch · 190 files changed
+11399/−8474 lines, 190 filesdep ~ghc-lib-parser
Dependency ranges changed: ghc-lib-parser
Files
- compiler/ClosureTypes.h +4/−0
- compiler/CodeGen.Platform.h +2/−2
- compiler/GHC.hs +8/−17
- compiler/GHC/ByteCode/Asm.hs +15/−5
- compiler/GHC/Cmm/CommonBlockElim.hs +4/−4
- compiler/GHC/Cmm/Config.hs +0/−1
- compiler/GHC/Cmm/ContFlowOpt.hs +0/−4
- compiler/GHC/Cmm/Dataflow.hs +3/−3
- compiler/GHC/Cmm/DebugBlock.hs +1/−1
- compiler/GHC/Cmm/Graph.hs +5/−4
- compiler/GHC/Cmm/Info.hs +6/−6
- compiler/GHC/Cmm/Info/Build.hs +3/−4
- compiler/GHC/Cmm/LayoutStack.hs +16/−13
- compiler/GHC/Cmm/Lint.hs +2/−2
- compiler/GHC/Cmm/Liveness.hs +2/−0
- compiler/GHC/Cmm/Parser.y +7/−6
- compiler/GHC/Cmm/Pipeline.hs +2/−3
- compiler/GHC/Cmm/Ppr.hs +4/−1
- compiler/GHC/Cmm/Ppr/Expr.hs +6/−1
- compiler/GHC/Cmm/ProcPoint.hs +2/−2
- compiler/GHC/Cmm/Sink.hs +11/−16
- compiler/GHC/Cmm/Switch/Implement.hs +3/−4
- compiler/GHC/Cmm/Utils.hs +20/−8
- compiler/GHC/CmmToAsm.hs +5/−6
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +4/−3
- compiler/GHC/CmmToAsm/AArch64/Instr.hs +1/−1
- compiler/GHC/CmmToAsm/AArch64/Ppr.hs +9/−29
- compiler/GHC/CmmToAsm/BlockLayout.hs +7/−10
- compiler/GHC/CmmToAsm/CFG.hs +2/−3
- compiler/GHC/CmmToAsm/Dwarf.hs +1/−1
- compiler/GHC/CmmToAsm/Dwarf/Types.hs +1/−2
- compiler/GHC/CmmToAsm/Monad.hs +40/−10
- compiler/GHC/CmmToAsm/PIC.hs +2/−1
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs +115/−135
- compiler/GHC/CmmToAsm/PPC/Instr.hs +1/−1
- compiler/GHC/CmmToAsm/PPC/Ppr.hs +1/−1
- compiler/GHC/CmmToAsm/Ppr.hs +31/−26
- compiler/GHC/CmmToAsm/Reg/Utils.hs +0/−1
- compiler/GHC/CmmToAsm/X86/CodeGen.hs +4299/−3993
- compiler/GHC/CmmToAsm/X86/Cond.hs +16/−16
- compiler/GHC/CmmToAsm/X86/Instr.hs +5/−4
- compiler/GHC/CmmToAsm/X86/Ppr.hs +3/−7
- compiler/GHC/CmmToC.hs +13/−11
- compiler/GHC/CmmToLlvm/Base.hs +2/−2
- compiler/GHC/CmmToLlvm/CodeGen.hs +105/−77
- compiler/GHC/CmmToLlvm/Config.hs +1/−1
- compiler/GHC/CmmToLlvm/Data.hs +1/−1
- compiler/GHC/Core/LateCC.hs +77/−0
- compiler/GHC/Core/Opt/CSE.hs +2/−2
- compiler/GHC/Core/Opt/CallArity.hs +6/−6
- compiler/GHC/Core/Opt/CprAnal.hs +1/−1
- compiler/GHC/Core/Opt/DmdAnal.hs +384/−29
- compiler/GHC/Core/Opt/Exitify.hs +1/−1
- compiler/GHC/Core/Opt/FloatIn.hs +7/−8
- compiler/GHC/Core/Opt/FloatOut.hs +2/−3
- compiler/GHC/Core/Opt/LiberateCase.hs +1/−1
- compiler/GHC/Core/Opt/Pipeline.hs +30/−20
- compiler/GHC/Core/Opt/Simplify.hs +5/−3
- compiler/GHC/Core/Opt/Simplify/Monad.hs +15/−7
- compiler/GHC/Core/Opt/Simplify/Utils.hs +12/−16
- compiler/GHC/Core/Opt/SpecConstr.hs +14/−5
- compiler/GHC/Core/Opt/Specialise.hs +3/−4
- compiler/GHC/Core/Opt/WorkWrap.hs +56/−29
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs +189/−363
- compiler/GHC/CoreToStg.hs +3/−1
- compiler/GHC/CoreToStg/Prep.hs +36/−15
- compiler/GHC/Driver/Backpack.hs +6/−6
- compiler/GHC/Driver/CodeOutput.hs +1/−1
- compiler/GHC/Driver/Config/Stg/Debug.hs +14/−0
- compiler/GHC/Driver/Config/Stg/Lift.hs +15/−0
- compiler/GHC/Driver/Config/Stg/Pipeline.hs +46/−0
- compiler/GHC/Driver/Config/Stg/Ppr.hs +13/−0
- compiler/GHC/Driver/Config/StgToCmm.hs +2/−0
- compiler/GHC/Driver/GenerateCgIPEStub.hs +10/−9
- compiler/GHC/Driver/Main.hs +119/−91
- compiler/GHC/Driver/Make.hs +100/−63
- compiler/GHC/Driver/Pipeline.hs +10/−34
- compiler/GHC/Driver/Pipeline/Execute.hs +5/−6
- compiler/GHC/HsToCore.hs +14/−5
- compiler/GHC/HsToCore/Coverage.hs +49/−41
- compiler/GHC/HsToCore/Expr.hs +1/−2
- compiler/GHC/HsToCore/Foreign/Decl.hs +1/−0
- compiler/GHC/HsToCore/Match.hs +2/−2
- compiler/GHC/HsToCore/Pmc/Desugar.hs +1/−1
- compiler/GHC/HsToCore/Pmc/Solver.hs +2/−2
- compiler/GHC/HsToCore/Quote.hs +8/−11
- compiler/GHC/HsToCore/Types.hs +1/−1
- compiler/GHC/HsToCore/Usage.hs +34/−20
- compiler/GHC/HsToCore/Utils.hs +1/−1
- compiler/GHC/Iface/Ext/Ast.hs +11/−10
- compiler/GHC/Iface/Make.hs +24/−20
- compiler/GHC/Iface/Recomp.hs +112/−83
- compiler/GHC/Iface/Recomp/Flags.hs +3/−5
- compiler/GHC/Iface/Tidy.hs +24/−17
- compiler/GHC/IfaceToCore.hs +49/−31
- compiler/GHC/Linker/Loader.hs +96/−100
- compiler/GHC/Llvm/Ppr.hs +17/−20
- compiler/GHC/Llvm/Syntax.hs +2/−2
- compiler/GHC/Rename/Bind.hs +3/−3
- compiler/GHC/Rename/Env.hs +12/−28
- compiler/GHC/Rename/Expr.hs +66/−18
- compiler/GHC/Rename/HsType.hs +26/−40
- compiler/GHC/Rename/Module.hs +3/−2
- compiler/GHC/Rename/Names.hs +62/−69
- compiler/GHC/Rename/Pat.hs +2/−2
- compiler/GHC/Rename/Splice.hs +1/−1
- compiler/GHC/Rename/Unbound.hs +3/−2
- compiler/GHC/Rename/Utils.hs +8/−72
- compiler/GHC/Runtime/Eval.hs +17/−14
- compiler/GHC/Runtime/Loader.hs +35/−28
- compiler/GHC/Stg/CSE.hs +7/−7
- compiler/GHC/Stg/Debug.hs +26/−12
- compiler/GHC/Stg/FVs.hs +1/−0
- compiler/GHC/Stg/InferTags.hs +631/−0
- compiler/GHC/Stg/InferTags/Rewrite.hs +494/−0
- compiler/GHC/Stg/InferTags/Types.hs +137/−0
- compiler/GHC/Stg/Lift.hs +6/−5
- compiler/GHC/Stg/Lift/Analysis.hs +7/−7
- compiler/GHC/Stg/Lift/Config.hs +21/−0
- compiler/GHC/Stg/Lift/Monad.hs +20/−12
- compiler/GHC/Stg/Lint.hs +21/−8
- compiler/GHC/Stg/Pipeline.hs +30/−35
- compiler/GHC/Stg/Stats.hs +1/−1
- compiler/GHC/Stg/Unarise.hs +3/−2
- compiler/GHC/Stg/Utils.hs +123/−0
- compiler/GHC/StgToByteCode.hs +42/−23
- compiler/GHC/StgToCmm.hs +4/−3
- compiler/GHC/StgToCmm/ArgRep.hs +1/−0
- compiler/GHC/StgToCmm/Bind.hs +20/−15
- compiler/GHC/StgToCmm/CgUtils.hs +2/−2
- compiler/GHC/StgToCmm/Closure.hs +49/−19
- compiler/GHC/StgToCmm/DataCon.hs +5/−2
- compiler/GHC/StgToCmm/Env.hs +10/−3
- compiler/GHC/StgToCmm/Expr.hs +129/−13
- compiler/GHC/StgToCmm/Foreign.hs +19/−21
- compiler/GHC/StgToCmm/Heap.hs +1/−2
- compiler/GHC/StgToCmm/Hpc.hs +1/−1
- compiler/GHC/StgToCmm/Layout.hs +4/−4
- compiler/GHC/StgToCmm/Monad.hs +8/−4
- compiler/GHC/StgToCmm/Prim.hs +37/−27
- compiler/GHC/StgToCmm/Prof.hs +4/−5
- compiler/GHC/StgToCmm/TagCheck.hs +156/−0
- compiler/GHC/StgToCmm/Ticky.hs +132/−3
- compiler/GHC/StgToCmm/Utils.hs +20/−11
- compiler/GHC/SysTools.hs +2/−2
- compiler/GHC/SysTools/Info.hs +9/−19
- compiler/GHC/Tc/Deriv/Generate.hs +1/−2
- compiler/GHC/Tc/Deriv/Infer.hs +6/−11
- compiler/GHC/Tc/Deriv/Utils.hs +1/−1
- compiler/GHC/Tc/Errors.hs +555/−409
- compiler/GHC/Tc/Errors/Hole.hs +38/−36
- compiler/GHC/Tc/Errors/Hole.hs-boot +3/−4
- compiler/GHC/Tc/Gen/App.hs +30/−22
- compiler/GHC/Tc/Gen/Arrow.hs +1/−1
- compiler/GHC/Tc/Gen/Bind.hs +76/−84
- compiler/GHC/Tc/Gen/Export.hs +2/−2
- compiler/GHC/Tc/Gen/Expr.hs +2/−3
- compiler/GHC/Tc/Gen/Head.hs +7/−4
- compiler/GHC/Tc/Gen/HsType.hs +18/−9
- compiler/GHC/Tc/Gen/Pat.hs +5/−12
- compiler/GHC/Tc/Gen/Rule.hs +19/−14
- compiler/GHC/Tc/Gen/Sig.hs +1/−1
- compiler/GHC/Tc/Gen/Splice.hs +5/−6
- compiler/GHC/Tc/Instance/Class.hs +2/−2
- compiler/GHC/Tc/Instance/Family.hs +8/−10
- compiler/GHC/Tc/Instance/FunDeps.hs +34/−25
- compiler/GHC/Tc/Module.hs +55/−25
- compiler/GHC/Tc/Plugin.hs +0/−5
- compiler/GHC/Tc/Solver.hs +438/−120
- compiler/GHC/Tc/Solver/Canonical.hs +358/−375
- compiler/GHC/Tc/Solver/Interact.hs +272/−262
- compiler/GHC/Tc/Solver/Monad.hs +162/−532
- compiler/GHC/Tc/Solver/Rewrite.hs +77/−118
- compiler/GHC/Tc/TyCl.hs +63/−19
- compiler/GHC/Tc/TyCl/Build.hs +1/−1
- compiler/GHC/Tc/TyCl/Instance.hs +2/−1
- compiler/GHC/Tc/TyCl/PatSyn.hs +3/−2
- compiler/GHC/Tc/Utils/Backpack.hs +3/−3
- compiler/GHC/Tc/Utils/Concrete.hs +12/−26
- compiler/GHC/Tc/Utils/Monad.hs +30/−32
- compiler/GHC/Tc/Utils/TcMType.hs +131/−46
- compiler/GHC/Tc/Utils/Unify.hs +58/−58
- compiler/GHC/Tc/Utils/Zonk.hs +12/−18
- compiler/GHC/Tc/Validity.hs +39/−72
- compiler/GHC/ThToHs.hs +2/−1
- compiler/GHC/Unit/Finder.hs +0/−1
- ghc-lib.cabal +15/−2
- ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs +1/−1
- ghc-lib/stage0/compiler/build/primop-docs.hs-incl +1/−1
- libraries/ghci/GHCi/TH.hs +1/−1
compiler/ClosureTypes.h view
@@ -18,6 +18,10 @@ * - the closure_type_names list in rts/Printer.c */ +/* CONSTR/THUNK/FUN_$A_$B mean they have $A pointers followed by $B+ * non-pointers in their payloads.+ */+ /* Object tag 0 raises an internal error */ #define INVALID_OBJECT 0 #define CONSTR 1
compiler/CodeGen.Platform.h view
@@ -834,7 +834,7 @@ # if defined(MACHREGS_i386) freeReg esp = False -- %esp is the C stack pointer-freeReg esi = False -- Note [esi/edi/ebp not allocatable]+freeReg esi = False -- See Note [esi/edi/ebp not allocatable] freeReg edi = False freeReg ebp = False # endif@@ -844,7 +844,7 @@ {- Note [esi/edi/ebp not allocatable]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ %esi is mapped to R1, so %esi would normally be allocatable while it is not being used for R1. However, %esi has no 8-bit version on x86, and the linear register allocator is not sophisticated enough to
compiler/GHC.hs view
@@ -25,7 +25,6 @@ runGhc, runGhcT, initGhcMonad, printException, handleSourceError,- needsTemplateHaskellOrQQ, -- * Flags and settings DynFlags(..), GeneralFlag(..), Severity(..), Backend(..), gopt,@@ -856,7 +855,7 @@ -- Initialise (load) plugins in the interactive environment with the new -- DynFlags- plugin_env <- liftIO $ flip initializePlugins Nothing $ mkInteractiveHscEnv $+ plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $ hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags'' }} -- Update both plugins cache and DynFlags in the interactive context.@@ -1249,7 +1248,7 @@ minf_type_env = md_types details, minf_exports = md_exports details, minf_rdr_env = Just (tcg_rdr_env tc_gbl_env),- minf_instances = fixSafeInstances safe $ md_insts details,+ minf_instances = fixSafeInstances safe $ instEnvElts $ md_insts details, minf_iface = Nothing, minf_safe = safe, minf_modBreaks = emptyModBreaks@@ -1387,7 +1386,8 @@ -- | Return the instances for the current interactive session. getInsts :: GhcMonad m => m ([ClsInst], [FamInst]) getInsts = withSession $ \hsc_env ->- return $ ic_instances (hsc_IC hsc_env)+ let (inst_env, fam_env) = ic_instances (hsc_IC hsc_env)+ in return (instEnvElts inst_env, fam_env) getPrintUnqual :: GhcMonad m => m PrintUnqualified getPrintUnqual = withSession $ \hsc_env -> do@@ -1406,22 +1406,13 @@ -- We don't want HomeModInfo here, because a ModuleInfo applies -- to package modules too. + -- | Request information about a loaded 'Module' getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X getModuleInfo mdl = withSession $ \hsc_env -> do- let mg = hsc_mod_graph hsc_env- if mgElemModule mg mdl+ if moduleUnitId mdl `S.member` hsc_all_home_unit_ids hsc_env then liftIO $ getHomeModuleInfo hsc_env mdl- else do- {- if isHomeModule (hsc_dflags hsc_env) mdl- then return Nothing- else -} liftIO $ getPackageModuleInfo hsc_env mdl- -- ToDo: we don't understand what the following comment means.- -- (SDM, 19/7/2011)- -- getPackageModuleInfo will attempt to find the interface, so- -- we don't want to call it for a home module, just in case there- -- was a problem loading the module and the interface doesn't- -- exist... hence the isHomeModule test here. (ToDo: reinstate)+ else liftIO $ getPackageModuleInfo hsc_env mdl getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) getPackageModuleInfo hsc_env mdl@@ -1466,7 +1457,7 @@ minf_type_env = md_types details, minf_exports = md_exports details, minf_rdr_env = mi_globals $! hm_iface hmi,- minf_instances = md_insts details,+ minf_instances = instEnvElts $ md_insts details, minf_iface = Just iface, minf_safe = getSafeMode $ mi_trust iface ,minf_modBreaks = getModBreaks hmi
compiler/GHC/ByteCode/Asm.hs view
@@ -497,7 +497,7 @@ litlabel fs = lit [BCONPtrLbl fs] addr (RemotePtr a) = words [fromIntegral a]- float = words . mkLitF+ float = words . mkLitF platform double = words . mkLitD platform int = words . mkLitI int8 = words . mkLitI64 platform@@ -586,18 +586,28 @@ -- words are placed in memory at increasing addresses, the -- bit pattern is correct for the host's word size and endianness. mkLitI :: Int -> [Word]-mkLitF :: Float -> [Word]+mkLitF :: Platform -> Float -> [Word] mkLitD :: Platform -> Double -> [Word] mkLitI64 :: Platform -> Int64 -> [Word] -mkLitF f- = runST (do+mkLitF platform f = case platformWordSize platform of+ PW4 -> runST $ do arr <- newArray_ ((0::Int),0) writeArray arr 0 f f_arr <- castSTUArray arr w0 <- readArray f_arr 0 return [w0 :: Word]- )++ PW8 -> runST $ do+ arr <- newArray_ ((0::Int),1)+ writeArray arr 0 f+ -- on 64-bit architectures we read two (32-bit) Float cells when we read+ -- a (64-bit) Word: so we write a dummy value in the second cell to+ -- avoid an out-of-bound read.+ writeArray arr 1 0.0+ f_arr <- castSTUArray arr+ w0 <- readArray f_arr 0+ return [w0 :: Word] mkLitD platform d = case platformWordSize platform of PW4 -> runST (do
compiler/GHC/Cmm/CommonBlockElim.hs view
@@ -144,7 +144,7 @@ hash_node :: CmmNode O x -> Word32 hash_node n | dont_care n = 0 -- don't care hash_node (CmmAssign r e) = hash_reg r + hash_e e- hash_node (CmmStore e e') = hash_e e + hash_e e'+ hash_node (CmmStore e e' _) = hash_e e + hash_e e' hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as hash_node (CmmBranch _) = 23 -- NB. ignore the label hash_node (CmmCondBranch p _ _ _) = hash_e p@@ -159,7 +159,7 @@ hash_e :: CmmExpr -> Word32 hash_e (CmmLit l) = hash_lit l- hash_e (CmmLoad e _) = 67 + hash_e e+ hash_e (CmmLoad e _ _) = 67 + hash_e e hash_e (CmmReg r) = hash_reg r hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check hash_e (CmmRegOff r i) = hash_reg r + cvt i@@ -210,7 +210,7 @@ -> CmmNode O O -> CmmNode O O -> Bool eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2) = r1 == r2 && eqExprWith eqBid e1 e2-eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2)+eqMiddleWith eqBid (CmmStore l1 r1 _) (CmmStore l2 r2 _) = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2 eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1) (CmmUnsafeForeignCall t2 r2 a2)@@ -222,7 +222,7 @@ eqExprWith eqBid = eq where CmmLit l1 `eq` CmmLit l2 = eqLit l1 l2- CmmLoad e1 _ `eq` CmmLoad e2 _ = e1 `eq` e2+ CmmLoad e1 t1 a1 `eq` CmmLoad e2 t2 a2 = t1 `cmmEqType` t2 && e1 `eq` e2 && a1==a2 CmmReg r1 `eq` CmmReg r2 = r1==r2 CmmRegOff r1 i1 `eq` CmmRegOff r2 i2 = r1==r2 && i1==i2 CmmMachOp op1 es1 `eq` CmmMachOp op2 es2 = op1==op2 && es1 `eqs` es2
compiler/GHC/Cmm/Config.hs view
@@ -1,7 +1,6 @@ -- | Cmm compilation configuration {-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} module GHC.Cmm.Config ( CmmConfig(..)
compiler/GHC/Cmm/ContFlowOpt.hs view
@@ -29,7 +29,6 @@ -- Note [What is shortcutting] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- Consider this Cmm code: -- -- L1: ...@@ -53,7 +52,6 @@ -- Note [Control-flow optimisations] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- This optimisation does three things: -- -- - If a block finishes in an unconditional branch to another block@@ -80,7 +78,6 @@ -- Note [Shortcut call returns] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- We are going to maintain the "current" graph (LabelMap CmmBlock) as -- we go, and also a mapping from BlockId to BlockId, representing -- continuation labels that we have renamed. This latter mapping is@@ -106,7 +103,6 @@ -- Note [Shortcut call returns and proc-points] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- Consider this code that you might get from a recursive -- let-no-escape: --
compiler/GHC/Cmm/Dataflow.hs view
@@ -294,7 +294,7 @@ fwd = revPostorderFrom blockmap entry -- Note [Backward vs forward analysis]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- The forward and backward cases are not dual. In the forward case, the entry -- points are known, and one simply traverses the body blocks from those points. -- In the backward case, something is known about the exit points, but a@@ -350,7 +350,7 @@ updateFact fact_join dep_blocks (todo, fbase) lbl new_fact = case lookupFact lbl fbase of Nothing ->- -- Note [No old fact]+ -- See Note [No old fact] let !z = mapInsert lbl new_fact fbase in (changed, z) Just old_fact -> case fact_join (OldFact old_fact) (NewFact new_fact) of@@ -362,7 +362,7 @@ {- Note [No old fact]-+~~~~~~~~~~~~~~~~~~ We know that the new_fact is >= _|_, so we don't need to join. However, if the new fact is also _|_, and we have already analysed its block, we don't need to record a change. So there's a tradeoff here. It turns
compiler/GHC/Cmm/DebugBlock.hs view
@@ -546,7 +546,7 @@ toUnwindExpr _ (CmmLit (CmmLabel l)) = UwLabel l toUnwindExpr _ (CmmRegOff (CmmGlobal g) i) = UwReg g i toUnwindExpr _ (CmmReg (CmmGlobal g)) = UwReg g 0-toUnwindExpr platform (CmmLoad e _) = UwDeref (toUnwindExpr platform e)+toUnwindExpr platform (CmmLoad e _ _) = UwDeref (toUnwindExpr platform e) toUnwindExpr platform e@(CmmMachOp op [e1, e2]) = case (op, toUnwindExpr platform e1, toUnwindExpr platform e2) of (MO_Add{}, UwReg r x, UwConst y) -> UwReg r (x + y)
compiler/GHC/Cmm/Graph.hs view
@@ -193,8 +193,9 @@ mkAssign l (CmmReg r) | l == r = mkNop mkAssign l r = mkMiddle $ CmmAssign l r +-- | Assumes natural alignment mkStore :: CmmExpr -> CmmExpr -> CmmAGraph-mkStore l r = mkMiddle $ CmmStore l r+mkStore l r = mkMiddle $ CmmStore l r NaturallyAligned ---------- Control transfer mkJump :: Profile -> Convention -> CmmExpr@@ -333,14 +334,14 @@ | isBitsType $ localRegType reg , typeWidth (localRegType reg) < wordWidth platform = let- stack_slot = (CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth platform))+ stack_slot = CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth platform) NaturallyAligned local = CmmLocal reg width = cmmRegWidth platform local expr = CmmMachOp (MO_XX_Conv (wordWidth platform) width) [stack_slot] in CmmAssign local expr | otherwise =- CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty)+ CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty NaturallyAligned) where ty = localRegType reg init_offset = widthInBytes (wordWidth platform) -- infotable@@ -425,7 +426,7 @@ -- Note [Width of parameters]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Consider passing a small (< word width) primitive like Int8# to a function. -- It's actually non-trivial to do this without extending/narrowing: -- * Global registers are considered to have native word width (i.e., 64-bits on
compiler/GHC/Cmm/Info.hs view
@@ -450,7 +450,7 @@ -- | Takes a closure pointer and returns the info table pointer closureInfoPtr :: Platform -> DoAlignSanitisation -> CmmExpr -> CmmExpr closureInfoPtr platform align_check e =- CmmLoad (wordAligned platform align_check e) (bWord platform)+ cmmLoadBWord platform (wordAligned platform align_check e) -- | Takes an info pointer (the first word of a closure) and returns its entry -- code@@ -458,7 +458,7 @@ entryCode platform e = if platformTablesNextToCode platform then e- else CmmLoad e (bWord platform)+ else cmmLoadBWord platform e -- | Takes a closure pointer, and return the *zero-indexed* -- constructor tag obtained from the info table@@ -498,24 +498,24 @@ -- field of the info table infoTableSrtBitmap :: Profile -> CmmExpr -> CmmExpr infoTableSrtBitmap profile info_tbl- = CmmLoad (cmmOffsetB platform info_tbl (stdSrtBitmapOffset profile)) (bHalfWord platform)+ = CmmLoad (cmmOffsetB platform info_tbl (stdSrtBitmapOffset profile)) (bHalfWord platform) NaturallyAligned where platform = profilePlatform profile -- | Takes an info table pointer (from infoTable) and returns the closure type -- field of the info table. infoTableClosureType :: Profile -> CmmExpr -> CmmExpr infoTableClosureType profile info_tbl- = CmmLoad (cmmOffsetB platform info_tbl (stdClosureTypeOffset profile)) (bHalfWord platform)+ = CmmLoad (cmmOffsetB platform info_tbl (stdClosureTypeOffset profile)) (bHalfWord platform) NaturallyAligned where platform = profilePlatform profile infoTablePtrs :: Profile -> CmmExpr -> CmmExpr infoTablePtrs profile info_tbl- = CmmLoad (cmmOffsetB platform info_tbl (stdPtrsOffset profile)) (bHalfWord platform)+ = CmmLoad (cmmOffsetB platform info_tbl (stdPtrsOffset profile)) (bHalfWord platform) NaturallyAligned where platform = profilePlatform profile infoTableNonPtrs :: Profile -> CmmExpr -> CmmExpr infoTableNonPtrs profile info_tbl- = CmmLoad (cmmOffsetB platform info_tbl (stdNonPtrsOffset profile)) (bHalfWord platform)+ = CmmLoad (cmmOffsetB platform info_tbl (stdNonPtrsOffset profile)) (bHalfWord platform) NaturallyAligned where platform = profilePlatform profile -- | Takes the info pointer of a function, and returns a pointer to the first
compiler/GHC/Cmm/Info/Build.hs view
@@ -55,7 +55,6 @@ {- Note [SRTs] ~~~~~~~~~~~- SRTs are the mechanism by which the garbage collector can determine the live CAFs in the program. @@ -758,7 +757,7 @@ , Just (id, _) <- [cit_clo info] , let rep = cit_rep info , isStaticRep rep && isFunRep rep- , let !lbl = mkLocalClosureLabel (idName id) (idCafInfo id)+ , let !lbl = mkClosureLabel (idName id) (idCafInfo id) ] @@ -925,7 +924,7 @@ {- Note [recursive SRTs]-+ ~~~~~~~~~~~~~~~~~~~~~ If the dependency analyser has found us a recursive group of declarations, then we build a single SRT for the whole group, on the grounds that everything in the group is reachable from everything@@ -1220,7 +1219,7 @@ HeapRep sta ptrs nptrs ty -> HeapRep sta (ptrs + length srtEntries) nptrs ty _other -> panic "maybeStaticFun"- lbl = mkLocalClosureLabel (idName id) caf_info+ lbl = mkClosureLabel (idName id) caf_info in Just (newInfo, mkDataLits (Section Data lbl) lbl fields) | otherwise = Nothing
compiler/GHC/Cmm/LayoutStack.hs view
@@ -39,7 +39,7 @@ import Data.List (nub) {- Note [Stack Layout]-+ ~~~~~~~~~~~~~~~~~~~ The job of this pass is to - replace references to abstract stack Areas with fixed offsets from Sp.@@ -141,7 +141,7 @@ Note [Two pass approach]-+~~~~~~~~~~~~~~~~~~~~~~~~ The main reason for Pass 2 is being able to insert only the reloads that are needed and the fact that the two passes need different liveness information. Let's consider an example:@@ -397,7 +397,7 @@ procMiddle :: LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap procMiddle stackmaps node sm = case node of- CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _)+ CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _ _) -> sm { sm_regs = addToUFM (sm_regs sm) r (r,loc) } where loc = getStackLoc area off stackmaps CmmAssign (CmmLocal r) _other@@ -510,7 +510,7 @@ , LabelMap StackMap ) handleBranches- -- Note [diamond proc point]+ -- See Note [diamond proc point] | Just l <- futureContinuation middle , (nub $ filter (`setMember` procpoints) $ successors last) == [l] = do@@ -605,7 +605,8 @@ move (r,n) | Just (_,m) <- lookupUFM old_map r, n == m = [] | otherwise = [CmmStore (CmmStackSlot Old n)- (CmmReg (CmmLocal r))]+ (CmmReg (CmmLocal r))+ NaturallyAligned] @@ -644,9 +645,8 @@ } --- ----------------------------------------------------------------------------- -- Note [diamond proc point]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~~ -- This special case looks for the pattern we get from a typical -- tagged case expression: --@@ -704,7 +704,7 @@ futureContinuation :: Block CmmNode O O -> Maybe BlockId futureContinuation middle = foldBlockNodesB f middle Nothing where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId- f (CmmStore (CmmStackSlot (Young l) _) (CmmLit (CmmBlock _))) _+ f (CmmStore (CmmStackSlot (Young l) _) (CmmLit (CmmBlock _)) _) _ = Just l f _ r = r @@ -753,6 +753,7 @@ select_save to_save (slot:stack) -> let assig = CmmStore (CmmStackSlot Old n') (CmmReg (CmmLocal r))+ NaturallyAligned n' = plusW platform n 1 in (to_save', stack', n', assig : assigs, (r,(r,n')):regs)@@ -787,6 +788,7 @@ n' = n + localRegBytes platform r assig = CmmStore (CmmStackSlot Old n') (CmmReg (CmmLocal r))+ NaturallyAligned trim_sp | not (null push_regs) = push_sp@@ -895,7 +897,7 @@ where sp_unwind = CmmRegOff spReg (sp0 - platformWordSizeInBytes platform - sp_off) {- Note [SP old/young offsets]-+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Sp(L) is the Sp offset on entry to block L relative to the base of the OLD area. @@ -996,7 +998,7 @@ go _stackmap [] = [] go stackmap (n:ns) = case n of- CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r))+ CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r)) _ | Just (_,off) <- lookupUFM (sm_regs stackmap) r , area_off area + m == off -> go stackmap ns@@ -1086,7 +1088,8 @@ -- This cmmOffset basically corresponds to manifesting -- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets] (CmmLoad (cmmOffset platform spExpr (sp_off - reg_off))- (localRegType reg))+ (localRegType reg)+ NaturallyAligned) | (reg, reg_off) <- stackSlotRegs stackmap , reg `elemRegSet` live ]@@ -1098,7 +1101,7 @@ {- Note [Lower safe foreign calls]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We start with Sp[young(L1)] = L1@@ -1165,7 +1168,7 @@ -- different. Hence we continue by jumping to the top stack frame, -- not by jumping to succ. jump = CmmCall { cml_target = entryCode platform $- CmmLoad spExpr (bWord platform)+ cmmLoadBWord platform spExpr , cml_cont = Just succ , cml_args_regs = regs , cml_args = widthInBytes (wordWidth platform)
compiler/GHC/Cmm/Lint.hs view
@@ -88,7 +88,7 @@ -- byte/word mismatches. lintCmmExpr :: CmmExpr -> CmmLint CmmType-lintCmmExpr (CmmLoad expr rep) = do+lintCmmExpr (CmmLoad expr rep _alignment) = do _ <- lintCmmExpr expr -- Disabled, if we have the inlining phase before the lint phase, -- we can have funny offsets due to pointer tagging. -- EZY@@ -174,7 +174,7 @@ then return () else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty - CmmStore l r -> do+ CmmStore l r _alignment -> do _ <- lintCmmExpr l _ <- lintCmmExpr r return ()
compiler/GHC/Cmm/Liveness.hs view
@@ -71,6 +71,8 @@ analyzeCmmBwd liveLattice (xferLive platform) graph mapEmpty -- | On entry to the procedure, there had better not be any LocalReg's live-in.+-- If you see this error it most likely means you are trying to use a variable+-- without it being defined in the given scope. noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a noLiveOnEntry bid in_fact x = if nullRegSet in_fact then x
compiler/GHC/Cmm/Parser.y view
@@ -6,9 +6,9 @@ -- ----------------------------------------------------------------------------- -{- -----------------------------------------------------------------------------+{- Note [Syntax of .cmm files]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~ NOTE: You are very much on your own in .cmm. There is very little error checking at all: @@ -214,7 +214,6 @@ import GHC.Platform.Profile import GHC.StgToCmm.ExtCode-import GHC.StgToCmm.Prof import GHC.StgToCmm.Heap import GHC.StgToCmm.Monad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit , emitStore, emitAssign, emitOutOfLine, withUpdFrameOff@@ -794,10 +793,13 @@ | STRING { do s <- code (newStringCLit $1); return (CmmLit s) } | reg { $1 }- | type '[' expr ']' { do e <- $3; return (CmmLoad e $1) }+ | type dereference { do (align, ptr) <- $2; return (CmmLoad ptr $1 align) } | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 } | '(' expr ')' { $2 } +dereference :: { CmmParse (AlignmentSpec, CmmExpr) }+ : '^' '[' expr ']' { do ptr <- $3; return (Unaligned, ptr) }+ | '[' expr ']' { do ptr <- $2; return (NaturallyAligned, ptr) } -- leaving out the type of a literal gives you the native word size in C-- maybe_ty :: { CmmType }@@ -1289,8 +1291,7 @@ mkReturnSimple :: Profile -> [CmmActual] -> UpdFrameOffset -> CmmAGraph mkReturnSimple profile actuals updfr_off = mkReturn profile e actuals updfr_off- where e = entryCode platform (CmmLoad (CmmStackSlot Old updfr_off)- (gcWord platform))+ where e = entryCode platform (cmmLoadGCWord platform (CmmStackSlot Old updfr_off)) platform = profilePlatform profile doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()
compiler/GHC/Cmm/Pipeline.hs view
@@ -175,7 +175,6 @@ -- Note [Sinking after stack layout] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- In the past we considered running sinking pass also before stack -- layout, but after making some measurements we realized that: --@@ -301,7 +300,7 @@ -- {- Note [inconsistent-pic-reg]-+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~ On x86/Darwin, PIC is implemented by inserting a sequence like call 1f@@ -329,7 +328,7 @@ -} {- Note [unreachable blocks]-+ ~~~~~~~~~~~~~~~~~~~~~~~~~ The control-flow optimiser sometimes leaves unreachable blocks behind containing junk code. These aren't necessarily a problem, but removing them is good because it might save time in the native code
compiler/GHC/Cmm/Ppr.hs view
@@ -215,8 +215,11 @@ CmmAssign reg expr -> ppr reg <+> equals <+> pdoc platform expr <> semi -- rep[lv] = expr;- CmmStore lv expr -> rep <> brackets (pdoc platform lv) <+> equals <+> pdoc platform expr <> semi+ CmmStore lv expr align -> rep <> align_mark <> brackets (pdoc platform lv) <+> equals <+> pdoc platform expr <> semi where+ align_mark = case align of+ Unaligned -> text "^"+ NaturallyAligned -> empty rep = ppr ( cmmExprType platform expr ) -- call "ccall" foo(x, y)[r1, r2];
compiler/GHC/Cmm/Ppr/Expr.hs view
@@ -149,7 +149,12 @@ pprExpr9 platform e = case e of CmmLit lit -> pprLit1 platform lit- CmmLoad expr rep -> ppr rep <> brackets (pdoc platform expr)+ CmmLoad expr rep align+ -> let align_mark =+ case align of+ NaturallyAligned -> empty+ Unaligned -> text "^"+ in ppr rep <> align_mark <> brackets (pdoc platform expr) CmmReg reg -> ppr reg CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off) CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off)
compiler/GHC/Cmm/ProcPoint.hs view
@@ -428,7 +428,7 @@ {- Note [Direct reachability]-+~~~~~~~~~~~~~~~~~~~~~~~~~~ Block B is directly reachable from proc point P iff control can flow from P to B without passing through an intervening proc point. -}@@ -437,7 +437,7 @@ {- Note [No simple dataflow]-+~~~~~~~~~~~~~~~~~~~~~~~~~ Sadly, it seems impossible to compute the proc points using a single dataflow pass. One might attempt to use this simple lattice:
compiler/GHC/Cmm/Sink.hs view
@@ -472,7 +472,7 @@ go usages live node skipped (a@(l,rhs,_) : rest) | cannot_inline = dont_inline- | occurs_none = discard -- Note [discard during inlining]+ | occurs_none = discard -- See Note [discard during inlining] | occurs_once = inline_and_discard | isTrivial platform rhs = inline_and_keep | otherwise = dont_inline@@ -496,7 +496,7 @@ live' = inline foldLocalRegsUsed platform (\m r -> insertLRegSet r m) live rhs - cannot_inline = skipped `regsUsedIn` rhs -- Note [dependent assignments]+ cannot_inline = skipped `regsUsedIn` rhs -- See Note [dependent assignments] || l `elemLRegSet` skipped || not (okToInline platform rhs node) @@ -519,8 +519,7 @@ inl_exp other = other {- Note [Keeping assignemnts mentioned in skipped RHSs]- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have to assignments: [z = y, y = e1] and we skip z we *must* retain the assignment y = e1. This is because we might inline "z = y" into another node later on so we@@ -541,7 +540,7 @@ -} {- Note [improveConditional]-+ ~~~~~~~~~~~~~~~~~~~~~~~~~ cmmMachOpFold tries to simplify conditionals to turn things like (a == b) != 1 into@@ -579,7 +578,6 @@ -- Note [dependent assignments] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- If our assignment list looks like -- -- [ y = e, x = ... y ... ]@@ -634,9 +632,9 @@ use _ls _ z = z go :: LRegSet -> CmmExpr -> Bool -> Bool- go ls (CmmMachOp _ es) z = foldr (go ls) z es- go ls (CmmLoad addr _) z = go ls addr z- go ls e z = use ls e z+ go ls (CmmMachOp _ es) z = foldr (go ls) z es+ go ls (CmmLoad addr _ _) z = go ls addr z+ go ls e z = use ls e z -- we don't inline into CmmUnsafeForeignCall if the expression refers -- to global registers. This is a HACK to avoid global registers@@ -665,7 +663,7 @@ | foldRegsUsed platform (\b r' -> r == r' || b) False node = True -- (3) a store to an address conflicts with a read of the same memory- | CmmStore addr' e <- node+ | CmmStore addr' e _ <- node , memConflicts addr (loadAddr platform addr' (cmmExprWidth platform e)) = True -- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively@@ -690,7 +688,6 @@ {- Note [Inlining foldRegsDefd] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~- foldRegsDefd is, after optimization, *not* a small function so it's only marked INLINEABLE, but not INLINE. @@ -720,7 +717,6 @@ -- Note [Sinking and calls] -- ~~~~~~~~~~~~~~~~~~~~~~~~--- -- We have three kinds of calls: normal (CmmCall), safe foreign (CmmForeignCall) -- and unsafe foreign (CmmUnsafeForeignCall). We perform sinking pass after -- stack layout (see Note [Sinking after stack layout]) which leads to two@@ -803,7 +799,6 @@ -- Note [Foreign calls clobber heap] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- It is tempting to say that foreign calls clobber only -- non-heap/stack memory, but unfortunately we break this invariant in -- the RTS. For example, in stg_catch_retry_frame we call@@ -850,9 +845,9 @@ memConflicts _ _ = True exprMem :: Platform -> CmmExpr -> AbsMem-exprMem platform (CmmLoad addr w) = bothMems (loadAddr platform addr (typeWidth w)) (exprMem platform addr)-exprMem platform (CmmMachOp _ es) = foldr bothMems NoMem (map (exprMem platform) es)-exprMem _ _ = NoMem+exprMem platform (CmmLoad addr w _) = bothMems (loadAddr platform addr (typeWidth w)) (exprMem platform addr)+exprMem platform (CmmMachOp _ es) = foldr bothMems NoMem (map (exprMem platform) es)+exprMem _ _ = NoMem loadAddr :: Platform -> CmmExpr -> Width -> AbsMem loadAddr platform e w =
compiler/GHC/Cmm/Switch/Implement.hs view
@@ -57,16 +57,15 @@ -- Note [Floating switch expressions] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- -- When we translate a sparse switch into a search tree we would like -- to compute the value we compare against only once.-+-- -- For this purpose we assign the switch expression to a local register -- and then use this register when constructing the actual binary tree.-+-- -- This is important as the expression could contain expensive code like -- memory loads or divisions which we REALLY don't want to duplicate.-+-- -- This happened in parts of the handwritten RTS Cmm code. See also #16933 -- See Note [Floating switch expressions]
compiler/GHC/Cmm/Utils.hs view
@@ -31,6 +31,7 @@ cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB, cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW, cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW,+ cmmLoadBWord, cmmLoadGCWord, cmmNegate, cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord, cmmSLtWord,@@ -47,7 +48,7 @@ currentTSOExpr, currentNurseryExpr, cccsExpr, -- Tagging- cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged,+ cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged, cmmIsNotTagged, cmmConstrTag1, mAX_PTR_TAG, tAG_MASK, -- Overlap and usage@@ -304,8 +305,17 @@ byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr platform (widthInLog width)] cmmLoadIndex :: Platform -> CmmType -> CmmExpr -> Int -> CmmExpr-cmmLoadIndex platform ty expr ix = CmmLoad (cmmIndex platform (typeWidth ty) expr ix) ty+cmmLoadIndex platform ty expr ix =+ CmmLoad (cmmIndex platform (typeWidth ty) expr ix) ty NaturallyAligned -- TODO: Audit uses +-- | Load a naturally-aligned non-pointer word.+cmmLoadBWord :: Platform -> CmmExpr -> CmmExpr+cmmLoadBWord platform ptr = CmmLoad ptr (bWord platform) NaturallyAligned++-- | Load a naturally-aligned GC pointer.+cmmLoadGCWord :: Platform -> CmmExpr -> CmmExpr+cmmLoadGCWord platform ptr = CmmLoad ptr (gcWord platform) NaturallyAligned+ -- The "B" variants take byte offsets cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr cmmRegOffB = cmmRegOff@@ -343,7 +353,8 @@ cmmLabelOffW platform lbl wd_off = cmmLabelOffB lbl (wordsToBytes platform wd_off) cmmLoadIndexW :: Platform -> CmmExpr -> Int -> CmmType -> CmmExpr-cmmLoadIndexW platform base off ty = CmmLoad (cmmOffsetW platform base off) ty+cmmLoadIndexW platform base off ty =+ CmmLoad (cmmOffsetW platform base off) ty NaturallyAligned -- TODO: Audit ses ----------------------- cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,@@ -394,7 +405,7 @@ --------------------------------------------------- isTrivialCmmExpr :: CmmExpr -> Bool-isTrivialCmmExpr (CmmLoad _ _) = False+isTrivialCmmExpr (CmmLoad _ _ _) = False isTrivialCmmExpr (CmmMachOp _ _) = False isTrivialCmmExpr (CmmLit _) = True isTrivialCmmExpr (CmmReg _) = True@@ -402,7 +413,7 @@ isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot" hasNoGlobalRegs :: CmmExpr -> Bool-hasNoGlobalRegs (CmmLoad e _) = hasNoGlobalRegs e+hasNoGlobalRegs (CmmLoad e _ _) = hasNoGlobalRegs e hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es hasNoGlobalRegs (CmmLit _) = True hasNoGlobalRegs (CmmReg (CmmLocal _)) = True@@ -436,13 +447,14 @@ -- Used to untag a possibly tagged pointer -- A static label need not be untagged-cmmUntag, cmmIsTagged, cmmConstrTag1 :: Platform -> CmmExpr -> CmmExpr+cmmUntag, cmmIsTagged, cmmIsNotTagged, cmmConstrTag1 :: Platform -> CmmExpr -> CmmExpr cmmUntag _ e@(CmmLit (CmmLabel _)) = e -- Default case cmmUntag platform e = cmmAndWord platform e (cmmPointerMask platform) --- Test if a closure pointer is untagged+-- Test if a closure pointer is untagged/tagged. cmmIsTagged platform e = cmmNeWord platform (cmmAndWord platform e (cmmTagMask platform)) (zeroExpr platform)+cmmIsNotTagged platform e = cmmEqWord platform (cmmAndWord platform e (cmmTagMask platform)) (zeroExpr platform) -- Get constructor tag, but one based. cmmConstrTag1 platform e = cmmAndWord platform e (cmmTagMask platform)@@ -474,7 +486,7 @@ regUsedIn :: Platform -> CmmReg -> CmmExpr -> Bool regUsedIn platform = regUsedIn_ where _ `regUsedIn_` CmmLit _ = False- reg `regUsedIn_` CmmLoad e _ = reg `regUsedIn_` e+ reg `regUsedIn_` CmmLoad e _ _ = reg `regUsedIn_` e reg `regUsedIn_` CmmReg reg' = regsOverlap platform reg reg' reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap platform reg reg' reg `regUsedIn_` CmmMachOp _ es = any (reg `regUsedIn_`) es
compiler/GHC/CmmToAsm.hs view
@@ -192,7 +192,6 @@ {- Note [Unwinding information in the NCG] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- Unwind information is a type of metadata which allows a debugging tool to reconstruct the values of machine registers at the time a procedure was entered. For the most part, the production of unwind information is handled by@@ -1024,10 +1023,10 @@ CmmReg reg' | reg == reg' -> CmmComment (fsLit "nop") new_src -> CmmAssign reg new_src - CmmStore addr src+ CmmStore addr src align -> do addr' <- cmmExprConFold DataReference addr src' <- cmmExprConFold DataReference src- return $ CmmStore addr' src'+ return $ CmmStore addr' src' align CmmCall { cml_target = addr } -> do addr' <- cmmExprConFold JumpReference addr@@ -1068,7 +1067,7 @@ cmmExprNative referenceKind expr' cmmExprCon :: NCGConfig -> CmmExpr -> CmmExpr-cmmExprCon config (CmmLoad addr rep) = CmmLoad (cmmExprCon config addr) rep+cmmExprCon config (CmmLoad addr rep align) = CmmLoad (cmmExprCon config addr) rep align cmmExprCon config (CmmMachOp mop args) = cmmMachOpFold (ncgPlatform config) mop (map (cmmExprCon config) args) cmmExprCon _ other = other@@ -1081,9 +1080,9 @@ let platform = ncgPlatform config arch = platformArch platform case expr of- CmmLoad addr rep+ CmmLoad addr rep align -> do addr' <- cmmExprNative DataReference addr- return $ CmmLoad addr' rep+ return $ CmmLoad addr' rep align CmmMachOp mop args -> do args' <- mapM (cmmExprNative DataReference) args
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs view
@@ -62,6 +62,7 @@ import GHC.Utils.Panic -- Note [General layout of an NCG]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- @cmmTopCodeGen@ will be our main entry point to code gen. Here we'll get -- @RawCmmDecl@; see GHC.Cmm --@@ -289,7 +290,7 @@ where ty = cmmRegType platform reg format = cmmTypeFormat ty - CmmStore addr src+ CmmStore addr src _alignment | isFloatType ty -> assignMem_FltCode format addr src | otherwise -> assignMem_IntCode format addr src where ty = cmmExprType platform src@@ -597,7 +598,7 @@ CmmLabelDiffOff _ _ _ _ -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr) CmmBlock _ -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr) CmmHighStackMark -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr)- CmmLoad mem rep -> do+ CmmLoad mem rep _ -> do Amode addr addr_code <- getAmode plat (typeWidth rep) mem let format = cmmTypeFormat rep return (Any format (\dst -> addr_code `snocOL` LDR format (OpReg (formatToWidth format) dst) (OpAddr addr)))@@ -846,7 +847,7 @@ MO_Sub w -> intOp False w (\d x y -> unitOL $ annExpr expr (SUB d x y)) -- Note [CSET]- --+ -- ~~~~~~~~~~~ -- Setting conditional flags: the architecture internally knows the -- following flag bits. And based on thsoe comparisons as in the -- table below.
compiler/GHC/CmmToAsm/AArch64/Instr.hs view
@@ -446,7 +446,7 @@ mkStackDeallocInstr _platform n = pprPanic "mkStackDeallocInstr" (int n) ----- See note [extra spill slots] in X86/Instr.hs+-- See Note [extra spill slots] in X86/Instr.hs -- allocMoreStack :: Platform
compiler/GHC/CmmToAsm/AArch64/Ppr.hs view
@@ -5,11 +5,6 @@ import GHC.Prelude hiding (EQ) -import Data.Word-import qualified Data.Array.Unsafe as U ( castSTUArray )-import Data.Array.ST-import Control.Monad.ST- import GHC.CmmToAsm.AArch64.Instr import GHC.CmmToAsm.AArch64.Regs import GHC.CmmToAsm.AArch64.Cond@@ -147,7 +142,7 @@ then ppr (mkAsmTempEndLabel info_lbl) <> char ':' else empty) -- Make sure the info table has the right .loc for the block- -- coming right after it. See [Note: Info Offset]+ -- coming right after it. See Note [Info Offset] infoTableLoc = case instrs of (l@LOCATION{} : _) -> pprInstr platform l _other -> empty@@ -187,11 +182,12 @@ | otherwise = text "\t.globl " <> pdoc platform lbl -- Note [Always use objects for info tables]--- See discussion in X86.Ppr--- for why this is necessary. Essentially we need to ensure that we never--- pass function symbols when we migth want to lookup the info table. If we--- did, we could end up with procedure linking tables (PLT)s, and thus the--- lookup wouldn't point to the function, but into the jump table.+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- See discussion in X86.Ppr for why this is necessary. Essentially we need to+-- ensure that we never pass function symbols when we migth want to lookup the+-- info table. If we did, we could end up with procedure linking tables+-- (PLT)s, and thus the lookup wouldn't point to the function, but into the+-- jump table. -- -- Fun fact: The LLVMMangler exists to patch this issue su on the LLVM side as -- well.@@ -227,29 +223,13 @@ ppr_item FF32 (CmmFloat r _) = let bs = floatToBytes (fromRational r)- in map (\b -> text "\t.byte\t" <> pprImm platform (ImmInt b)) bs+ in map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs ppr_item FF64 (CmmFloat r _) = let bs = doubleToBytes (fromRational r)- in map (\b -> text "\t.byte\t" <> pprImm platform (ImmInt b)) bs+ in map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs ppr_item _ _ = pprPanic "pprDataItem:ppr_item" (text $ show lit)--floatToBytes :: Float -> [Int]-floatToBytes f- = runST (do- arr <- newArray_ ((0::Int),3)- writeArray arr 0 f- arr <- castFloatToWord8Array arr- i0 <- readArray arr 0- i1 <- readArray arr 1- i2 <- readArray arr 2- i3 <- readArray arr 3- return (map fromIntegral [i0,i1,i2,i3])- )--castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)-castFloatToWord8Array = U.castSTUArray pprImm :: Platform -> Imm -> SDoc pprImm _ (ImmInt i) = int i
compiler/GHC/CmmToAsm/BlockLayout.hs view
@@ -67,10 +67,9 @@ * Feed this CFG into the block layout code (`sequenceTop`) in this module. Which will then produce a code layout based on the input weights. - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- ~~~ Note [Chain based CFG serialization]- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Note [Chain based CFG serialization]+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For additional information also look at https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/code-layout @@ -189,10 +188,9 @@ While E does not follow X it's still beneficial to place them near each other. This can be advantageous if eg C,X,E will end up in the same cache line. - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- ~~~ Note [Triangle Control Flow]- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Note [Triangle Control Flow]+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Checking if an argument is already evaluated leads to a somewhat special case which looks like this: @@ -240,10 +238,9 @@ Assuming that Lwork is large the chance that the "call" ends up in the same cache line is also fairly small. - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- ~~~ Note [Layout relevant edge weights]- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Note [Layout relevant edge weights]+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The input to the chain based code layout algorithm is a CFG with edges annotated with their frequency. The frequency of traversal corresponds quite well to the cost of not placing@@ -373,9 +370,9 @@ takeL n (BlockChain blks) = take n . fromOL $ blks + -- Note [Combining neighborhood chains] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- -- See also Note [Chain based CFG serialization] -- We have the chains (A-B-C-D) and (E-F) and an Edge C->E. --
compiler/GHC/CmmToAsm/CFG.hs view
@@ -150,7 +150,7 @@ -- or has it been introduced during assembly codegen. We use this to maintain -- some information which would otherwise be lost during the -- Cmm \<-> asm transition.--- See also Note [Inverting Conditional Branches]+-- See also Note [Inverting conditions] data TransitionSource = CmmSource { trans_cmmNode :: (CmmNode O C) , trans_info :: BranchInfo }@@ -248,7 +248,7 @@ {- Note [Updating the CFG during shortcutting]-+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See Note [What is shortcutting] in the control flow optimization code (GHC.Cmm.ContFlowOpt) for a slightly more in depth explanation on shortcutting. @@ -1013,7 +1013,6 @@ {- Note [Static Branch Prediction] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- The work here has been based on the paper "Static Branch Prediction and Program Profile Analysis" by Y Wu, JR Larus.
compiler/GHC/CmmToAsm/Dwarf.hs view
@@ -148,7 +148,7 @@ {- Note [Splitting DebugBlocks]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~ DWARF requires that we break up the nested DebugBlocks produced from the C-- AST. For instance, we begin with tick trees containing nested procs. For example,
compiler/GHC/CmmToAsm/Dwarf/Types.hs view
@@ -257,7 +257,7 @@ pprDwarfARange :: Platform -> DwarfARange -> SDoc pprDwarfARange platform arng =- -- Offset due to Note [Info offset].+ -- Offset due to Note [Info Offset]. pprWord platform (pdoc platform (dwArngStartLabel arng) <> text "-1") $$ pprWord platform length where@@ -410,7 +410,6 @@ -- Note [Info Offset] -- ~~~~~~~~~~~~~~~~~~--- -- GDB was pretty much written with C-like programs in mind, and as a -- result they assume that once you have a return address, it is a -- good idea to look at (PC-1) to unwind further - as that's where the
compiler/GHC/CmmToAsm/Monad.hs view
@@ -29,7 +29,6 @@ getBlockIdNat, getNewLabelNat, getNewRegNat,- getNewRegPairNat, getPicBaseMaybeNat, getPicBaseNat, getCfgWeights,@@ -37,7 +36,11 @@ getFileId, getDebugBlock, - DwarfFiles+ DwarfFiles,++ -- * 64-bit registers on 32-bit architectures+ Reg64(..), RegCode64(..),+ getNewReg64, localReg64 ) where@@ -56,6 +59,8 @@ import GHC.Cmm.Dataflow.Label import GHC.Cmm.CLabel ( CLabel ) import GHC.Cmm.DebugBlock+import GHC.Cmm.Expr (LocalReg (..), isWord64)+ import GHC.Data.FastString ( FastString ) import GHC.Types.Unique.FM import GHC.Types.Unique.Supply@@ -66,6 +71,7 @@ import GHC.Utils.Outputable (SDoc, ppr) import GHC.Utils.Panic (pprPanic)+import GHC.Utils.Misc import GHC.CmmToAsm.CFG import GHC.CmmToAsm.CFG.Weight @@ -254,14 +260,38 @@ return (RegVirtual $ targetMkVirtualReg platform u rep) -getNewRegPairNat :: Format -> NatM (Reg,Reg)-getNewRegPairNat rep- = do u <- getUniqueNat- platform <- getPlatform- let vLo = targetMkVirtualReg platform u rep- let lo = RegVirtual $ targetMkVirtualReg platform u rep- let hi = RegVirtual $ getHiVirtualRegFromLo vLo- return (lo, hi)+-- | Two 32-bit regs used as a single virtual 64-bit register+data Reg64 = Reg64+ !Reg -- ^ Higher part+ !Reg -- ^ Lower part++-- | Two 32-bit regs used as a single virtual 64-bit register+-- and the code to set them appropriately+data RegCode64 code = RegCode64+ code -- ^ Code to initialize the registers+ !Reg -- ^ Higher part+ !Reg -- ^ Lower part++-- | Return a virtual 64-bit register+getNewReg64 :: NatM Reg64+getNewReg64 = do+ let rep = II32+ u <- getUniqueNat+ platform <- getPlatform+ let vLo = targetMkVirtualReg platform u rep+ let lo = RegVirtual $ targetMkVirtualReg platform u rep+ let hi = RegVirtual $ getHiVirtualRegFromLo vLo+ return $ Reg64 hi lo++-- | Convert a 64-bit LocalReg into two virtual 32-bit regs.+--+-- Used to handle 64-bit "registers" on 32-bit architectures+localReg64 :: HasDebugCallStack => LocalReg -> Reg64+localReg64 (LocalReg vu ty)+ | isWord64 ty = let lo = RegVirtual (VirtualRegI vu)+ hi = getHiVRegFromLo lo+ in Reg64 hi lo+ | otherwise = pprPanic "localReg64" (ppr ty) getPicBaseMaybeNat :: NatM (Maybe Reg)
compiler/GHC/CmmToAsm/PIC.hs view
@@ -63,6 +63,7 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm import GHC.Cmm.CLabel+import GHC.Cmm.Utils (cmmLoadBWord) import GHC.Types.Basic @@ -134,7 +135,7 @@ AccessViaSymbolPtr -> do let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl addImport symbolPtr- return $ CmmLoad (cmmMakePicReference config symbolPtr) (bWord platform)+ return $ cmmLoadBWord platform (cmmMakePicReference config symbolPtr) AccessDirectly -> case referenceKind of -- for data, we might have to make some calculations:
compiler/GHC/CmmToAsm/PPC/CodeGen.hs view
@@ -33,7 +33,8 @@ ( DebugBlock(..) ) import GHC.CmmToAsm.Monad ( NatM, getNewRegNat, getNewLabelNat- , getBlockIdNat, getPicBaseNat, getNewRegPairNat+ , getBlockIdNat, getPicBaseNat+ , Reg64(..), RegCode64(..), getNewReg64, localReg64 , getPicBaseMaybeNat, getPlatform, getConfig , getDebugBlock, getFileId )@@ -174,7 +175,7 @@ where ty = cmmRegType platform reg format = cmmTypeFormat ty - CmmStore addr src+ CmmStore addr src _alignment | isFloatType ty -> assignMem_FltCode format addr src | target32Bit platform && isWord64 ty -> assignMem_I64Code addr src@@ -222,12 +223,15 @@ swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code swizzleRegisterRep (Any _ codefn) format = Any format codefn +getLocalRegReg :: LocalReg -> Reg+getLocalRegReg (LocalReg u pk)+ = RegVirtual (mkVirtualReg u (cmmTypeFormat pk)) -- | Grab the Reg for a CmmReg getRegisterReg :: Platform -> CmmReg -> Reg -getRegisterReg _ (CmmLocal (LocalReg u pk))- = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)+getRegisterReg _ (CmmLocal local_reg)+ = getLocalRegReg local_reg getRegisterReg platform (CmmGlobal mid) = case globalRegMaybe platform mid of@@ -274,16 +278,6 @@ by applying getHiVRegFromLo to it. -} -data ChildCode64 -- a.k.a "Register64"- = ChildCode64- InstrBlock -- code- Reg -- the lower 32-bit temporary which contains the- -- result; use getHiVRegFromLo to find the other- -- VRegUnique. Rules of this simplified insn- -- selection game are therefore that the returned- -- Reg may be modified-- -- | Compute an expression into a register, but -- we don't mind which one it is. getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)@@ -310,10 +304,8 @@ assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock assignMem_I64Code addrTree valueTree = do (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree- ChildCode64 vcode rlo <- iselExpr64 valueTree+ RegCode64 vcode rhi rlo <- iselExpr64 valueTree let- rhi = getHiVRegFromLo rlo- -- Big-endian store mov_hi = ST II32 rhi hi_addr mov_lo = ST II32 rlo lo_addr@@ -321,14 +313,11 @@ assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock-assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do- ChildCode64 vcode r_src_lo <- iselExpr64 valueTree- let- r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32- r_dst_hi = getHiVRegFromLo r_dst_lo- r_src_hi = getHiVRegFromLo r_src_lo- mov_lo = MR r_dst_lo r_src_lo- mov_hi = MR r_dst_hi r_src_hi+assignReg_I64Code (CmmLocal lreg) valueTree = do+ RegCode64 vcode r_src_hi r_src_lo <- iselExpr64 valueTree+ let Reg64 r_dst_hi r_dst_lo = localReg64 lreg+ mov_lo = MR r_dst_lo r_src_lo+ mov_hi = MR r_dst_hi r_src_hi return ( vcode `snocOL` mov_lo `snocOL` mov_hi )@@ -337,20 +326,21 @@ = panic "assignReg_I64Code(powerpc): invalid lvalue" -iselExpr64 :: CmmExpr -> NatM ChildCode64-iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do+iselExpr64 :: CmmExpr -> NatM (RegCode64 InstrBlock)+iselExpr64 (CmmLoad addrTree ty _) | isWord64 ty = do (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree- (rlo, rhi) <- getNewRegPairNat II32+ Reg64 rhi rlo <- getNewReg64 let mov_hi = LD II32 rhi hi_addr mov_lo = LD II32 rlo lo_addr- return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)- rlo+ return $ RegCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)+ rhi rlo -iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty- = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32))+iselExpr64 (CmmReg (CmmLocal local_reg)) = do+ let Reg64 hi lo = localReg64 local_reg+ return (RegCode64 nilOL hi lo) iselExpr64 (CmmLit (CmmInt i _)) = do- (rlo,rhi) <- getNewRegPairNat II32+ Reg64 rhi rlo <- getNewReg64 let half0 = fromIntegral (fromIntegral i :: Word16) half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16)@@ -363,49 +353,45 @@ LIS rhi (ImmInt half3), OR rhi rhi (RIImm $ ImmInt half2) ]- return (ChildCode64 code rlo)+ return (RegCode64 code rhi rlo) iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do- ChildCode64 code1 r1lo <- iselExpr64 e1- ChildCode64 code2 r2lo <- iselExpr64 e2- (rlo,rhi) <- getNewRegPairNat II32+ RegCode64 code1 r1hi r1lo <- iselExpr64 e1+ RegCode64 code2 r2hi r2lo <- iselExpr64 e2+ Reg64 rhi rlo <- getNewReg64 let- r1hi = getHiVRegFromLo r1lo- r2hi = getHiVRegFromLo r2lo code = code1 `appOL` code2 `appOL` toOL [ ADDC rlo r1lo r2lo, ADDE rhi r1hi r2hi ]- return (ChildCode64 code rlo)+ return (RegCode64 code rhi rlo) iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do- ChildCode64 code1 r1lo <- iselExpr64 e1- ChildCode64 code2 r2lo <- iselExpr64 e2- (rlo,rhi) <- getNewRegPairNat II32+ RegCode64 code1 r1hi r1lo <- iselExpr64 e1+ RegCode64 code2 r2hi r2lo <- iselExpr64 e2+ Reg64 rhi rlo <- getNewReg64 let- r1hi = getHiVRegFromLo r1lo- r2hi = getHiVRegFromLo r2lo code = code1 `appOL` code2 `appOL` toOL [ SUBFC rlo r2lo (RIReg r1lo), SUBFE rhi r2hi r1hi ]- return (ChildCode64 code rlo)+ return (RegCode64 code rhi rlo) iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do (expr_reg,expr_code) <- getSomeReg expr- (rlo, rhi) <- getNewRegPairNat II32+ Reg64 rhi rlo <- getNewReg64 let mov_hi = LI rhi (ImmInt 0) mov_lo = MR rlo expr_reg- return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)- rlo+ return $ RegCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)+ rhi rlo iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do (expr_reg,expr_code) <- getSomeReg expr- (rlo, rhi) <- getNewRegPairNat II32+ Reg64 rhi rlo <- getNewReg64 let mov_hi = SRA II32 rhi expr_reg (RIImm (ImmInt 31)) mov_lo = MR rlo expr_reg- return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)- rlo+ return $ RegCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)+ rhi rlo iselExpr64 expr = do platform <- getPlatform@@ -443,26 +429,26 @@ getRegister' _ platform (CmmMachOp (MO_UU_Conv W64 W32) [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) | target32Bit platform = do- ChildCode64 code rlo <- iselExpr64 x+ RegCode64 code _rhi rlo <- iselExpr64 x return $ Fixed II32 (getHiVRegFromLo rlo) code getRegister' _ platform (CmmMachOp (MO_SS_Conv W64 W32) [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) | target32Bit platform = do- ChildCode64 code rlo <- iselExpr64 x+ RegCode64 code _rhi rlo <- iselExpr64 x return $ Fixed II32 (getHiVRegFromLo rlo) code getRegister' _ platform (CmmMachOp (MO_UU_Conv W64 W32) [x]) | target32Bit platform = do- ChildCode64 code rlo <- iselExpr64 x+ RegCode64 code _rhi rlo <- iselExpr64 x return $ Fixed II32 rlo code getRegister' _ platform (CmmMachOp (MO_SS_Conv W64 W32) [x]) | target32Bit platform = do- ChildCode64 code rlo <- iselExpr64 x+ RegCode64 code _rhi rlo <- iselExpr64 x return $ Fixed II32 rlo code -getRegister' _ platform (CmmLoad mem pk)+getRegister' _ platform (CmmLoad mem pk _) | not (isWord64 pk) = do Amode addr addr_code <- getAmode D mem let code dst = assert ((targetClassOfReg platform dst == RcDouble) == isFloatType pk) $@@ -476,45 +462,45 @@ where format = cmmTypeFormat pk -- catch simple cases of zero- or sign-extended load-getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _]) = do+getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _ _]) = do Amode addr addr_code <- getAmode D mem return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr)) -getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W32) [CmmLoad mem _]) = do+getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W32) [CmmLoad mem _ _]) = do Amode addr addr_code <- getAmode D mem return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr)) -getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad mem _]) = do+getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad mem _ _]) = do Amode addr addr_code <- getAmode D mem return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr)) -getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W64) [CmmLoad mem _]) = do+getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W64) [CmmLoad mem _ _]) = do Amode addr addr_code <- getAmode D mem return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr)) -- Note: there is no Load Byte Arithmetic instruction, so no signed case here -getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _]) = do+getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _ _]) = do Amode addr addr_code <- getAmode D mem return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr)) -getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _]) = do+getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _ _]) = do Amode addr addr_code <- getAmode D mem return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr)) -getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad mem _]) = do+getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad mem _ _]) = do Amode addr addr_code <- getAmode D mem return (Any II64 (\dst -> addr_code `snocOL` LD II16 dst addr)) -getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad mem _]) = do+getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad mem _ _]) = do Amode addr addr_code <- getAmode D mem return (Any II64 (\dst -> addr_code `snocOL` LA II16 dst addr)) -getRegister' _ _ (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad mem _]) = do+getRegister' _ _ (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad mem _ _]) = do Amode addr addr_code <- getAmode D mem return (Any II64 (\dst -> addr_code `snocOL` LD II32 dst addr)) -getRegister' _ _ (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad mem _]) = do+getRegister' _ _ (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad mem _ _]) = do -- lwa is DS-form. See Note [Power instruction format] Amode addr addr_code <- getAmode DS mem return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr))@@ -738,6 +724,7 @@ -} {- Note [Power instruction format]+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In some instructions the 16 bit offset must be a multiple of 4, i.e. the two least significant bits must be zero. The "Power ISA" specification calls these instruction formats "DS-FORM" and the instructions with@@ -926,10 +913,8 @@ condIntCode' True cond W64 x y | condUnsigned cond = do- ChildCode64 code_x x_lo <- iselExpr64 x- ChildCode64 code_y y_lo <- iselExpr64 y- let x_hi = getHiVRegFromLo x_lo- y_hi = getHiVRegFromLo y_lo+ RegCode64 code_x x_hi x_lo <- iselExpr64 x+ RegCode64 code_y y_hi y_lo <- iselExpr64 y end_lbl <- getBlockIdNat let code = code_x `appOL` code_y `appOL` toOL [ CMPL II32 x_hi (RIReg y_hi)@@ -942,10 +927,8 @@ return (CondCode False cond code) | otherwise = do- ChildCode64 code_x x_lo <- iselExpr64 x- ChildCode64 code_y y_lo <- iselExpr64 y- let x_hi = getHiVRegFromLo x_lo- y_hi = getHiVRegFromLo y_lo+ RegCode64 code_x x_hi x_lo <- iselExpr64 x+ RegCode64 code_y y_hi y_lo <- iselExpr64 y end_lbl <- getBlockIdNat cmp_lo <- getBlockIdNat let code = code_x `appOL` code_y `appOL` toOL@@ -1142,9 +1125,8 @@ = return $ nilOL genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n]- = do platform <- getPlatform- let fmt = intFormat width- reg_dst = getRegisterReg platform (CmmLocal dst)+ = do let fmt = intFormat width+ reg_dst = getLocalRegReg dst (instr, n_code) <- case amop of AMO_Add -> getSomeRegOrImm ADD True reg_dst AMO_Sub -> case n of@@ -1193,9 +1175,8 @@ return (op dst dst (RIReg n_reg), n_code) genCCall (PrimTarget (MO_AtomicRead width)) [dst] [addr]- = do platform <- getPlatform- let fmt = intFormat width- reg_dst = getRegisterReg platform (CmmLocal dst)+ = do let fmt = intFormat width+ reg_dst = getLocalRegReg dst form = if widthInBits width == 64 then DS else D Amode addr_reg addr_code <- getAmode form addr lbl_end <- getBlockIdNat@@ -1210,6 +1191,7 @@ ] -- Note [Seemingly useless cmp and bne]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- In Power ISA, Book II, Section 4.4.1, Instruction Synchronize Instruction -- the second paragraph says that isync may complete before storage accesses -- "associated" with a preceding instruction have been performed. The cmp@@ -1226,14 +1208,13 @@ genCCall (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] | width == W32 || width == W64 = do- platform <- getPlatform (old_reg, old_code) <- getSomeReg old (new_reg, new_code) <- getSomeReg new (addr_reg, addr_code) <- getSomeReg addr lbl_retry <- getBlockIdNat lbl_eq <- getBlockIdNat lbl_end <- getBlockIdNat- let reg_dst = getRegisterReg platform (CmmLocal dst)+ let reg_dst = getLocalRegReg dst code = toOL [ HWSYNC , BCC ALWAYS lbl_retry Nothing@@ -1256,15 +1237,14 @@ genCCall (PrimTarget (MO_Clz width)) [dst] [src] = do platform <- getPlatform- let reg_dst = getRegisterReg platform (CmmLocal dst)+ let reg_dst = getLocalRegReg dst if target32Bit platform && width == W64 then do- ChildCode64 code vr_lo <- iselExpr64 src+ RegCode64 code vr_hi vr_lo <- iselExpr64 src lbl1 <- getBlockIdNat lbl2 <- getBlockIdNat lbl3 <- getBlockIdNat- let vr_hi = getHiVRegFromLo vr_lo- cntlz = toOL [ CMPL II32 vr_hi (RIImm (ImmInt 0))+ let cntlz = toOL [ CMPL II32 vr_hi (RIImm (ImmInt 0)) , BCC NE lbl2 Nothing , BCC ALWAYS lbl1 Nothing @@ -1307,11 +1287,11 @@ genCCall (PrimTarget (MO_Ctz width)) [dst] [src] = do platform <- getPlatform- let reg_dst = getRegisterReg platform (CmmLocal dst)+ let reg_dst = getLocalRegReg dst if target32Bit platform && width == W64 then do let format = II32- ChildCode64 code vr_lo <- iselExpr64 src+ RegCode64 code vr_hi vr_lo <- iselExpr64 src lbl1 <- getBlockIdNat lbl2 <- getBlockIdNat lbl3 <- getBlockIdNat@@ -1319,8 +1299,7 @@ x'' <- getNewRegNat format r' <- getNewRegNat format cnttzlo <- cnttz format reg_dst vr_lo- let vr_hi = getHiVRegFromLo vr_lo- cnttz64 = toOL [ CMPL format vr_lo (RIImm (ImmInt 0))+ let cnttz64 = toOL [ CMPL format vr_lo (RIImm (ImmInt 0)) , BCC NE lbl2 Nothing , BCC ALWAYS lbl1 Nothing @@ -1373,38 +1352,38 @@ genCCall target dest_regs argsAndHints = do platform <- getPlatform case target of- PrimTarget (MO_S_QuotRem width) -> divOp1 platform True width+ PrimTarget (MO_S_QuotRem width) -> divOp1 True width dest_regs argsAndHints- PrimTarget (MO_U_QuotRem width) -> divOp1 platform False width+ PrimTarget (MO_U_QuotRem width) -> divOp1 False width dest_regs argsAndHints- PrimTarget (MO_U_QuotRem2 width) -> divOp2 platform width dest_regs+ PrimTarget (MO_U_QuotRem2 width) -> divOp2 width dest_regs argsAndHints- PrimTarget (MO_U_Mul2 width) -> multOp2 platform width dest_regs+ PrimTarget (MO_U_Mul2 width) -> multOp2 width dest_regs argsAndHints- PrimTarget (MO_Add2 _) -> add2Op platform dest_regs argsAndHints- PrimTarget (MO_AddWordC _) -> addcOp platform dest_regs argsAndHints- PrimTarget (MO_SubWordC _) -> subcOp platform dest_regs argsAndHints- PrimTarget (MO_AddIntC width) -> addSubCOp ADDO platform width+ PrimTarget (MO_Add2 _) -> add2Op dest_regs argsAndHints+ PrimTarget (MO_AddWordC _) -> addcOp dest_regs argsAndHints+ PrimTarget (MO_SubWordC _) -> subcOp dest_regs argsAndHints+ PrimTarget (MO_AddIntC width) -> addSubCOp ADDO width dest_regs argsAndHints- PrimTarget (MO_SubIntC width) -> addSubCOp SUBFO platform width+ PrimTarget (MO_SubIntC width) -> addSubCOp SUBFO width dest_regs argsAndHints- PrimTarget MO_F64_Fabs -> fabs platform dest_regs argsAndHints- PrimTarget MO_F32_Fabs -> fabs platform dest_regs argsAndHints+ PrimTarget MO_F64_Fabs -> fabs dest_regs argsAndHints+ PrimTarget MO_F32_Fabs -> fabs dest_regs argsAndHints _ -> do config <- getConfig genCCall' config (platformToGCP platform) target dest_regs argsAndHints- where divOp1 platform signed width [res_q, res_r] [arg_x, arg_y]- = do let reg_q = getRegisterReg platform (CmmLocal res_q)- reg_r = getRegisterReg platform (CmmLocal res_r)+ where divOp1 signed width [res_q, res_r] [arg_x, arg_y]+ = do let reg_q = getLocalRegReg res_q+ reg_r = getLocalRegReg res_r remainderCode width signed reg_q arg_x arg_y <*> pure reg_r - divOp1 _ _ _ _ _+ divOp1 _ _ _ _ = panic "genCCall: Wrong number of arguments for divOp1"- divOp2 platform width [res_q, res_r]+ divOp2 width [res_q, res_r] [arg_x_high, arg_x_low, arg_y]- = do let reg_q = getRegisterReg platform (CmmLocal res_q)- reg_r = getRegisterReg platform (CmmLocal res_r)+ = do let reg_q = getLocalRegReg res_q+ reg_r = getLocalRegReg res_r fmt = intFormat width half = 4 * (formatInBytes fmt) (xh_reg, xh_code) <- getSomeReg arg_x_high@@ -1541,11 +1520,11 @@ , SL fmt reg_q q1 (RIImm (ImmInt half)) , ADD reg_q reg_q (RIReg q0) ]- divOp2 _ _ _ _+ divOp2 _ _ _ = panic "genCCall: Wrong number of arguments for divOp2"- multOp2 platform width [res_h, res_l] [arg_x, arg_y]- = do let reg_h = getRegisterReg platform (CmmLocal res_h)- reg_l = getRegisterReg platform (CmmLocal res_l)+ multOp2 width [res_h, res_l] [arg_x, arg_y]+ = do let reg_h = getLocalRegReg res_h+ reg_l = getLocalRegReg res_l fmt = intFormat width (x_reg, x_code) <- getSomeReg arg_x (y_reg, y_code) <- getSomeReg arg_y@@ -1553,11 +1532,11 @@ `appOL` toOL [ MULL fmt reg_l x_reg (RIReg y_reg) , MULHU fmt reg_h x_reg y_reg ]- multOp2 _ _ _ _+ multOp2 _ _ _ = panic "genCall: Wrong number of arguments for multOp2"- add2Op platform [res_h, res_l] [arg_x, arg_y]- = do let reg_h = getRegisterReg platform (CmmLocal res_h)- reg_l = getRegisterReg platform (CmmLocal res_l)+ add2Op [res_h, res_l] [arg_x, arg_y]+ = do let reg_h = getLocalRegReg res_h+ reg_l = getLocalRegReg res_l (x_reg, x_code) <- getSomeReg arg_x (y_reg, y_code) <- getSomeReg arg_y return $ y_code `appOL` x_code@@ -1565,20 +1544,20 @@ , ADDC reg_l x_reg y_reg , ADDZE reg_h reg_h ]- add2Op _ _ _+ add2Op _ _ = panic "genCCall: Wrong number of arguments/results for add2" - addcOp platform [res_r, res_c] [arg_x, arg_y]- = add2Op platform [res_c {-hi-}, res_r {-lo-}] [arg_x, arg_y]- addcOp _ _ _+ addcOp [res_r, res_c] [arg_x, arg_y]+ = add2Op [res_c {-hi-}, res_r {-lo-}] [arg_x, arg_y]+ addcOp _ _ = panic "genCCall: Wrong number of arguments/results for addc" -- PowerPC subfc sets the carry for rT = ~(rA) + rB + 1, -- which is 0 for borrow and 1 otherwise. We need 1 and 0 -- so xor with 1.- subcOp platform [res_r, res_c] [arg_x, arg_y]- = do let reg_r = getRegisterReg platform (CmmLocal res_r)- reg_c = getRegisterReg platform (CmmLocal res_c)+ subcOp [res_r, res_c] [arg_x, arg_y]+ = do let reg_r = getLocalRegReg res_r+ reg_c = getLocalRegReg res_c (x_reg, x_code) <- getSomeReg arg_x (y_reg, y_code) <- getSomeReg arg_y return $ y_code `appOL` x_code@@ -1587,11 +1566,11 @@ , ADDZE reg_c reg_c , XOR reg_c reg_c (RIImm (ImmInt 1)) ]- subcOp _ _ _+ subcOp _ _ = panic "genCCall: Wrong number of arguments/results for subc"- addSubCOp instr platform width [res_r, res_c] [arg_x, arg_y]- = do let reg_r = getRegisterReg platform (CmmLocal res_r)- reg_c = getRegisterReg platform (CmmLocal res_c)+ addSubCOp instr width [res_r, res_c] [arg_x, arg_y]+ = do let reg_r = getLocalRegReg res_r+ reg_c = getLocalRegReg res_c (x_reg, x_code) <- getSomeReg arg_x (y_reg, y_code) <- getSomeReg arg_y return $ y_code `appOL` x_code@@ -1599,13 +1578,13 @@ -- SUBFO argument order reversed! MFOV (intFormat width) reg_c ]- addSubCOp _ _ _ _ _+ addSubCOp _ _ _ _ = panic "genCall: Wrong number of arguments/results for addC"- fabs platform [res] [arg]- = do let res_r = getRegisterReg platform (CmmLocal res)+ fabs [res] [arg]+ = do let res_r = getLocalRegReg res (arg_reg, arg_code) <- getSomeReg arg return $ arg_code `snocOL` FABS res_r arg_reg- fabs _ _ _+ fabs _ _ = panic "genCall: Wrong number of arguments/results for fabs" -- TODO: replace 'Int' by an enum such as 'PPC_64ABI'@@ -1815,8 +1794,7 @@ accumCode accumUsed | isWord64 arg_ty && target32Bit (ncgPlatform config) = do- ChildCode64 code vr_lo <- iselExpr64 arg- let vr_hi = getHiVRegFromLo vr_lo+ RegCode64 code vr_hi vr_lo <- iselExpr64 arg case gcp of GCPAIX ->@@ -1976,7 +1954,7 @@ MR r_dest r4] | otherwise -> unitOL (MR r_dest r3) where rep = cmmRegType platform (CmmLocal dest)- r_dest = getRegisterReg platform (CmmLocal dest)+ r_dest = getLocalRegReg dest _ -> panic "genCCall' moveResult: Bad dest_regs" outOfLineMachOp mop =@@ -2535,12 +2513,14 @@ coerceFP2Int' _ _ _ _ = panic "PPC.CodeGen.coerceFP2Int: unknown arch" -- Note [.LCTOC1 in PPC PIC code]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- The .LCTOC1 label is defined to point 32768 bytes into the GOT table -- to make the most of the PPC's 16-bit displacements. -- As 16-bit signed offset is used (usually via addi/lwz instructions) -- first element will have '-32768' offset against .LCTOC1. -- Note [implicit register in PPC PIC code]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- PPC generates calls by labels in assembly -- in form of: -- bl puts+32768@plt
compiler/GHC/CmmToAsm/PPC/Instr.hs view
@@ -97,7 +97,7 @@ immAmount = ImmInt amount ----- See note [extra spill slots] in X86/Instr.hs+-- See Note [extra spill slots] in X86/Instr.hs -- allocMoreStack :: Platform
compiler/GHC/CmmToAsm/PPC/Ppr.hs view
@@ -154,7 +154,7 @@ pprDatas :: Platform -> RawCmmStatics -> SDoc--- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".+-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l
compiler/GHC/CmmToAsm/Ppr.hs view
@@ -11,6 +11,7 @@ module GHC.CmmToAsm.Ppr ( doubleToBytes,+ floatToBytes, pprASCII, pprString, pprFileEmbed,@@ -34,7 +35,6 @@ import Data.Array.ST import Control.Monad.ST- import Data.Word import Data.ByteString (ByteString) import qualified Data.ByteString as BS@@ -50,33 +50,38 @@ -- ----------------------------------------------------------------------------- -- Converting floating-point literals to integrals for printing -castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8)-castDoubleToWord8Array = U.castSTUArray---- floatToBytes and doubleToBytes convert to the host's byte--- order. Providing that we're not cross-compiling for a--- target with the opposite endianness, this should work ok--- on all targets.+-- | Get bytes of a Float representation+floatToBytes :: Float -> [Word8]+floatToBytes f = runST $ do+ arr <- newArray_ ((0::Int),3)+ writeArray arr 0 f+ let cast :: STUArray s Int Float -> ST s (STUArray s Int Word8)+ cast = U.castSTUArray+ arr <- cast arr+ i0 <- readArray arr 0+ i1 <- readArray arr 1+ i2 <- readArray arr 2+ i3 <- readArray arr 3+ return [i0,i1,i2,i3] --- ToDo: this stuff is very similar to the shenanigans in PprAbs,--- could they be merged?+-- | Get bytes of a Double representation+doubleToBytes :: Double -> [Word8]+doubleToBytes d = runST $ do+ arr <- newArray_ ((0::Int),7)+ writeArray arr 0 d+ let cast :: STUArray s Int Double -> ST s (STUArray s Int Word8)+ cast = U.castSTUArray+ arr <- cast arr+ i0 <- readArray arr 0+ i1 <- readArray arr 1+ i2 <- readArray arr 2+ i3 <- readArray arr 3+ i4 <- readArray arr 4+ i5 <- readArray arr 5+ i6 <- readArray arr 6+ i7 <- readArray arr 7+ return [i0,i1,i2,i3,i4,i5,i6,i7] -doubleToBytes :: Double -> [Int]-doubleToBytes d- = runST (do- arr <- newArray_ ((0::Int),7)- writeArray arr 0 d- arr <- castDoubleToWord8Array arr- i0 <- readArray arr 0- i1 <- readArray arr 1- i2 <- readArray arr 2- i3 <- readArray arr 3- i4 <- readArray arr 4- i5 <- readArray arr 5- i6 <- readArray arr 6- i7 <- readArray arr 7- return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7])- ) -- --------------------------------------------------------------------------- -- Printing ASCII strings.
compiler/GHC/CmmToAsm/Reg/Utils.hs view
@@ -4,7 +4,6 @@ {- Note [UniqFM and the register allocator] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- Before UniqFM had a key type the register allocator wasn't picky about key types, using VirtualReg, Reg and Unique at various use sites for the same map.
compiler/GHC/CmmToAsm/X86/CodeGen.hs view
@@ -1,3994 +1,4300 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE TupleSections #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}------------------------------------------------------------------------------------- Generating machine code (instruction selection)------ (c) The University of Glasgow 1996-2004------------------------------------------------------------------------------------- This is a big module, but, if you pay attention to--- (a) the sectioning, and (b) the type signatures, the--- structure should not be too overwhelming.--module GHC.CmmToAsm.X86.CodeGen (- cmmTopCodeGen,- generateJumpTableForInstr,- extractUnwindPoints,- invertCondBranches,- InstrBlock-)--where---- NCG stuff:-import GHC.Prelude--import GHC.CmmToAsm.X86.Instr-import GHC.CmmToAsm.X86.Cond-import GHC.CmmToAsm.X86.Regs-import GHC.CmmToAsm.X86.Ppr-import GHC.CmmToAsm.X86.RegInfo--import GHC.Platform.Regs-import GHC.CmmToAsm.CPrim-import GHC.CmmToAsm.Types-import GHC.Cmm.DebugBlock- ( DebugBlock(..), UnwindPoint(..), UnwindTable- , UnwindExpr(UwReg), toUnwindExpr- )-import GHC.CmmToAsm.PIC-import GHC.CmmToAsm.Monad- ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat- , getDeltaNat, getBlockIdNat, getPicBaseNat, getNewRegPairNat- , getPicBaseMaybeNat, getDebugBlock, getFileId- , addImmediateSuccessorNat, updateCfgNat, getConfig, getPlatform- , getCfgWeights- )-import GHC.CmmToAsm.CFG-import GHC.CmmToAsm.Format-import GHC.CmmToAsm.Config-import GHC.Platform.Reg-import GHC.Platform---- Our intermediate code:-import GHC.Types.Basic-import GHC.Cmm.BlockId-import GHC.Unit.Types ( primUnitId )-import GHC.Cmm.Utils-import GHC.Cmm.Switch-import GHC.Cmm-import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections-import GHC.Cmm.Dataflow.Graph-import GHC.Cmm.Dataflow.Label-import GHC.Cmm.CLabel-import GHC.Types.Tickish ( GenTickish(..) )-import GHC.Types.SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )---- The rest:-import GHC.Types.ForeignCall ( CCallConv(..) )-import GHC.Data.OrdList-import GHC.Utils.Outputable-import GHC.Utils.Constants (debugIsOn)-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Data.FastString-import GHC.Driver.Session-import GHC.Utils.Misc-import GHC.Types.Unique.Supply ( getUniqueM )--import Control.Monad-import Data.Foldable (fold)-import Data.Int-import Data.Maybe-import Data.Word--import qualified Data.Map as M--is32BitPlatform :: NatM Bool-is32BitPlatform = do- platform <- getPlatform- return $ target32Bit platform--sse2Enabled :: NatM Bool-sse2Enabled = do- config <- getConfig- return (ncgSseVersion config >= Just SSE2)--sse4_2Enabled :: NatM Bool-sse4_2Enabled = do- config <- getConfig- return (ncgSseVersion config >= Just SSE42)--cmmTopCodeGen- :: RawCmmDecl- -> NatM [NatCmmDecl (Alignment, RawCmmStatics) Instr]--cmmTopCodeGen (CmmProc info lab live graph) = do- let blocks = toBlockListEntryFirst graph- (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks- picBaseMb <- getPicBaseMaybeNat- platform <- getPlatform- let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)- tops = proc : concat statics- os = platformOS platform-- case picBaseMb of- Just picBase -> initializePicBase_x86 ArchX86 os picBase tops- Nothing -> return tops--cmmTopCodeGen (CmmData sec dat) =- return [CmmData sec (mkAlignment 1, dat)] -- no translation, we just use CmmStatic--{- Note [Verifying basic blocks]- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-- We want to guarantee a few things about the results- of instruction selection.-- Namely that each basic blocks consists of:- * A (potentially empty) sequence of straight line instructions- followed by- * A (potentially empty) sequence of jump like instructions.-- We can verify this by going through the instructions and- making sure that any non-jumpish instruction can't appear- after a jumpish instruction.-- There are gotchas however:- * CALLs are strictly speaking control flow but here we care- not about them. Hence we treat them as regular instructions.-- It's safe for them to appear inside a basic block- as (ignoring side effects inside the call) they will result in- straight line code.-- * NEWBLOCK marks the start of a new basic block so can- be followed by any instructions.--}---- Verifying basic blocks is cheap, but not cheap enough to enable it unconditionally.-verifyBasicBlock :: Platform -> [Instr] -> ()-verifyBasicBlock platform instrs- | debugIsOn = go False instrs- | otherwise = ()- where- go _ [] = ()- go atEnd (i:instr)- = case i of- -- Start a new basic block- NEWBLOCK {} -> go False instr- -- Calls are not viable block terminators- CALL {} | atEnd -> faultyBlockWith i- | not atEnd -> go atEnd instr- -- All instructions ok, check if we reached the end and continue.- _ | not atEnd -> go (isJumpishInstr i) instr- -- Only jumps allowed at the end of basic blocks.- | otherwise -> if isJumpishInstr i- then go True instr- else faultyBlockWith i- faultyBlockWith i- = pprPanic "Non control flow instructions after end of basic block."- (pprInstr platform i <+> text "in:" $$ vcat (map (pprInstr platform) instrs))--basicBlockCodeGen- :: CmmBlock- -> NatM ( [NatBasicBlock Instr]- , [NatCmmDecl (Alignment, RawCmmStatics) Instr])--basicBlockCodeGen block = do- let (_, nodes, tail) = blockSplit block- id = entryLabel block- stmts = blockToList nodes- -- Generate location directive- dbg <- getDebugBlock (entryLabel block)- loc_instrs <- case dblSourceTick =<< dbg of- Just (SourceNote span name)- -> do fileId <- getFileId (srcSpanFile span)- let line = srcSpanStartLine span; col = srcSpanStartCol span- return $ unitOL $ LOCATION fileId line col name- _ -> return nilOL- (mid_instrs,mid_bid) <- stmtsToInstrs id stmts- (!tail_instrs,_) <- stmtToInstrs mid_bid tail- let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs- platform <- getPlatform- return $! verifyBasicBlock platform (fromOL instrs)- instrs' <- fold <$> traverse addSpUnwindings instrs- -- code generation may introduce new basic block boundaries, which- -- are indicated by the NEWBLOCK instruction. We must split up the- -- instruction stream into basic blocks again. Also, we extract- -- LDATAs here too.- let- (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs'-- mkBlocks (NEWBLOCK id) (instrs,blocks,statics)- = ([], BasicBlock id instrs : blocks, statics)- mkBlocks (LDATA sec dat) (instrs,blocks,statics)- = (instrs, blocks, CmmData sec dat:statics)- mkBlocks instr (instrs,blocks,statics)- = (instr:instrs, blocks, statics)- return (BasicBlock id top : other_blocks, statics)---- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes--- in the @sp@ register. See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock"--- for details.-addSpUnwindings :: Instr -> NatM (OrdList Instr)-addSpUnwindings instr@(DELTA d) = do- config <- getConfig- if ncgDwarfUnwindings config- then do lbl <- mkAsmTempLabel <$> getUniqueM- let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d)- return $ toOL [ instr, UNWIND lbl unwind ]- else return (unitOL instr)-addSpUnwindings instr = return $ unitOL instr--{- Note [Keeping track of the current block]- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--When generating instructions for Cmm we sometimes require-the current block for things like retry loops.--We also sometimes change the current block, if a MachOP-results in branching control flow.--Issues arise if we have two statements in the same block,-which both depend on the current block id *and* change the-basic block after them. This happens for atomic primops-in the X86 backend where we want to update the CFG data structure-when introducing new basic blocks.--For example in #17334 we got this Cmm code:-- c3Bf: // global- (_s3t1::I64) = call MO_AtomicRMW W64 AMO_And(_s3sQ::P64 + 88, 18);- (_s3t4::I64) = call MO_AtomicRMW W64 AMO_Or(_s3sQ::P64 + 88, 0);- _s3sT::I64 = _s3sV::I64;- goto c3B1;--This resulted in two new basic blocks being inserted:-- c3Bf:- movl $18,%vI_n3Bo- movq 88(%vI_s3sQ),%rax- jmp _n3Bp- n3Bp:- ...- cmpxchgq %vI_n3Bq,88(%vI_s3sQ)- jne _n3Bp- ...- jmp _n3Bs- n3Bs:- ...- cmpxchgq %vI_n3Bt,88(%vI_s3sQ)- jne _n3Bs- ...- jmp _c3B1- ...--Based on the Cmm we called stmtToInstrs we translated both atomic operations under-the assumption they would be placed into their Cmm basic block `c3Bf`.-However for the retry loop we introduce new labels, so this is not the case-for the second statement.-This resulted in a desync between the explicit control flow graph-we construct as a separate data type and the actual control flow graph in the code.--Instead we now return the new basic block if a statement causes a change-in the current block and use the block for all following statements.--For this reason genCCall is also split into two parts. One for calls which-*won't* change the basic blocks in which successive instructions will be-placed (since they only evaluate CmmExpr, which can only contain MachOps, which-cannot introduce basic blocks in their lowerings). A different one for calls-which *are* known to change the basic block.---}---- See Note [Keeping track of the current block] for why--- we pass the BlockId.-stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in.- -> [CmmNode O O] -- ^ Cmm Statement- -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction-stmtsToInstrs bid stmts =- go bid stmts nilOL- where- go bid [] instrs = return (instrs,bid)- go bid (s:stmts) instrs = do- (instrs',bid') <- stmtToInstrs bid s- -- If the statement introduced a new block, we use that one- let !newBid = fromMaybe bid bid'- go newBid stmts (instrs `appOL` instrs')---- | `bid` refers to the current block and is used to update the CFG--- if new blocks are inserted in the control flow.--- See Note [Keeping track of the current block] for more details.-stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in.- -> CmmNode e x- -> NatM (InstrBlock, Maybe BlockId)- -- ^ Instructions, and bid of new block if successive- -- statements are placed in a different basic block.-stmtToInstrs bid stmt = do- is32Bit <- is32BitPlatform- platform <- getPlatform- case stmt of- CmmUnsafeForeignCall target result_regs args- -> genCCall is32Bit target result_regs args bid-- _ -> (,Nothing) <$> case stmt of- CmmComment s -> return (unitOL (COMMENT $ ftext s))- CmmTick {} -> return nilOL-- CmmUnwind regs -> do- let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable- to_unwind_entry (reg, expr) = M.singleton reg (fmap (toUnwindExpr platform) expr)- case foldMap to_unwind_entry regs of- tbl | M.null tbl -> return nilOL- | otherwise -> do- lbl <- mkAsmTempLabel <$> getUniqueM- return $ unitOL $ UNWIND lbl tbl-- CmmAssign reg src- | isFloatType ty -> assignReg_FltCode format reg src- | is32Bit && isWord64 ty -> assignReg_I64Code reg src- | otherwise -> assignReg_IntCode format reg src- where ty = cmmRegType platform reg- format = cmmTypeFormat ty-- CmmStore addr src- | isFloatType ty -> assignMem_FltCode format addr src- | is32Bit && isWord64 ty -> assignMem_I64Code addr src- | otherwise -> assignMem_IntCode format addr src- where ty = cmmExprType platform src- format = cmmTypeFormat ty-- CmmBranch id -> return $ genBranch id-- --We try to arrange blocks such that the likely branch is the fallthrough- --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.- CmmCondBranch arg true false _ -> genCondBranch bid true false arg- CmmSwitch arg ids -> genSwitch arg ids- CmmCall { cml_target = arg- , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs)- _ ->- panic "stmtToInstrs: statement should have been cps'd away"---jumpRegs :: Platform -> [GlobalReg] -> [Reg]-jumpRegs platform gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]------------------------------------------------------------------------------------- | 'InstrBlock's are the insn sequences generated by the insn selectors.--- They are really trees of insns to facilitate fast appending, where a--- left-to-right traversal yields the insns in the correct order.----type InstrBlock- = OrdList Instr----- | Condition codes passed up the tree.----data CondCode- = CondCode Bool Cond InstrBlock----- | a.k.a "Register64"--- Reg is the lower 32-bit temporary which contains the result.--- Use getHiVRegFromLo to find the other VRegUnique.------ Rules of this simplified insn selection game are therefore that--- the returned Reg may be modified----data ChildCode64- = ChildCode64- InstrBlock- Reg----- | Register's passed up the tree. If the stix code forces the register--- to live in a pre-decided machine register, it comes out as @Fixed@;--- otherwise, it comes out as @Any@, and the parent can decide which--- register to put it in.----data Register- = Fixed Format Reg InstrBlock- | Any Format (Reg -> InstrBlock)---swizzleRegisterRep :: Register -> Format -> Register-swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code-swizzleRegisterRep (Any _ codefn) format = Any format codefn----- | Grab the Reg for a CmmReg-getRegisterReg :: Platform -> CmmReg -> Reg--getRegisterReg _ (CmmLocal (LocalReg u pk))- = -- by Assuming SSE2, Int,Word,Float,Double all can be register allocated- let fmt = cmmTypeFormat pk in- RegVirtual (mkVirtualReg u fmt)--getRegisterReg platform (CmmGlobal mid)- = case globalRegMaybe platform mid of- Just reg -> RegReal $ reg- Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)- -- By this stage, the only MagicIds remaining should be the- -- ones which map to a real machine register on this- -- platform. Hence ...----- | Memory addressing modes passed up the tree.-data Amode- = Amode AddrMode InstrBlock--{--Now, given a tree (the argument to a CmmLoad) that references memory,-produce a suitable addressing mode.--A Rule of the Game (tm) for Amodes: use of the addr bit must-immediately follow use of the code part, since the code part puts-values in registers which the addr then refers to. So you can't put-anything in between, lest it overwrite some of those registers. If-you need to do some other computation between the code part and use of-the addr bit, first store the effective address from the amode in a-temporary, then do the other computation, and then use the temporary:-- code- LEA amode, tmp- ... other computation ...- ... (tmp) ...--}----- | Check whether an integer will fit in 32 bits.--- A CmmInt is intended to be truncated to the appropriate--- number of bits, so here we truncate it to Int64. This is--- important because e.g. -1 as a CmmInt might be either--- -1 or 18446744073709551615.----is32BitInteger :: Integer -> Bool-is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000- where i64 = fromIntegral i :: Int64----- | Convert a BlockId to some CmmStatic data-jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic-jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config))-jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)- where blockLabel = blockLbl blockid----- -------------------------------------------------------------------------------- General things for putting together code sequences---- Expand CmmRegOff. ToDo: should we do it this way around, or convert--- CmmExprs into CmmRegOff?-mangleIndexTree :: Platform -> CmmReg -> Int -> CmmExpr-mangleIndexTree platform reg off- = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]- where width = typeWidth (cmmRegType platform reg)---- | The dual to getAnyReg: compute an expression into a register, but--- we don't mind which one it is.-getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)-getSomeReg expr = do- r <- getRegister expr- case r of- Any rep code -> do- tmp <- getNewRegNat rep- return (tmp, code tmp)- Fixed _ reg code ->- return (reg, code)---assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock-assignMem_I64Code addrTree valueTree = do- Amode addr addr_code <- getAmode addrTree- ChildCode64 vcode rlo <- iselExpr64 valueTree- let- rhi = getHiVRegFromLo rlo-- -- Little-endian store- mov_lo = MOV II32 (OpReg rlo) (OpAddr addr)- mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4)))- return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)---assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock-assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do- ChildCode64 vcode r_src_lo <- iselExpr64 valueTree- let- r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32- r_dst_hi = getHiVRegFromLo r_dst_lo- r_src_hi = getHiVRegFromLo r_src_lo- mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo)- mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi)- return (- vcode `snocOL` mov_lo `snocOL` mov_hi- )--assignReg_I64Code _ _- = panic "assignReg_I64Code(i386): invalid lvalue"---iselExpr64 :: CmmExpr -> NatM ChildCode64-iselExpr64 (CmmLit (CmmInt i _)) = do- (rlo,rhi) <- getNewRegPairNat II32- let- r = fromIntegral (fromIntegral i :: Word32)- q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)- code = toOL [- MOV II32 (OpImm (ImmInteger r)) (OpReg rlo),- MOV II32 (OpImm (ImmInteger q)) (OpReg rhi)- ]- return (ChildCode64 code rlo)--iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do- Amode addr addr_code <- getAmode addrTree- (rlo,rhi) <- getNewRegPairNat II32- let- mov_lo = MOV II32 (OpAddr addr) (OpReg rlo)- mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi)- return (- ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)- rlo- )--iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty- = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32))---- we handle addition, but rather badly-iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do- ChildCode64 code1 r1lo <- iselExpr64 e1- (rlo,rhi) <- getNewRegPairNat II32- let- r = fromIntegral (fromIntegral i :: Word32)- q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)- r1hi = getHiVRegFromLo r1lo- code = code1 `appOL`- toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),- ADD II32 (OpImm (ImmInteger r)) (OpReg rlo),- MOV II32 (OpReg r1hi) (OpReg rhi),- ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ]- return (ChildCode64 code rlo)--iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do- ChildCode64 code1 r1lo <- iselExpr64 e1- ChildCode64 code2 r2lo <- iselExpr64 e2- (rlo,rhi) <- getNewRegPairNat II32- let- r1hi = getHiVRegFromLo r1lo- r2hi = getHiVRegFromLo r2lo- code = code1 `appOL`- code2 `appOL`- toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),- ADD II32 (OpReg r2lo) (OpReg rlo),- MOV II32 (OpReg r1hi) (OpReg rhi),- ADC II32 (OpReg r2hi) (OpReg rhi) ]- return (ChildCode64 code rlo)--iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do- ChildCode64 code1 r1lo <- iselExpr64 e1- ChildCode64 code2 r2lo <- iselExpr64 e2- (rlo,rhi) <- getNewRegPairNat II32- let- r1hi = getHiVRegFromLo r1lo- r2hi = getHiVRegFromLo r2lo- code = code1 `appOL`- code2 `appOL`- toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),- SUB II32 (OpReg r2lo) (OpReg rlo),- MOV II32 (OpReg r1hi) (OpReg rhi),- SBB II32 (OpReg r2hi) (OpReg rhi) ]- return (ChildCode64 code rlo)--iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do- fn <- getAnyReg expr- r_dst_lo <- getNewRegNat II32- let r_dst_hi = getHiVRegFromLo r_dst_lo- code = fn r_dst_lo- return (- ChildCode64 (code `snocOL`- MOV II32 (OpImm (ImmInt 0)) (OpReg r_dst_hi))- r_dst_lo- )--iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do- fn <- getAnyReg expr- r_dst_lo <- getNewRegNat II32- let r_dst_hi = getHiVRegFromLo r_dst_lo- code = fn r_dst_lo- return (- ChildCode64 (code `snocOL`- MOV II32 (OpReg r_dst_lo) (OpReg eax) `snocOL`- CLTD II32 `snocOL`- MOV II32 (OpReg eax) (OpReg r_dst_lo) `snocOL`- MOV II32 (OpReg edx) (OpReg r_dst_hi))- r_dst_lo- )--iselExpr64 expr- = do- platform <- getPlatform- pprPanic "iselExpr64(i386)" (pdoc platform expr)------------------------------------------------------------------------------------getRegister :: CmmExpr -> NatM Register-getRegister e = do platform <- getPlatform- is32Bit <- is32BitPlatform- getRegister' platform is32Bit e--getRegister' :: Platform -> Bool -> CmmExpr -> NatM Register--getRegister' platform is32Bit (CmmReg reg)- = case reg of- CmmGlobal PicBaseReg- | is32Bit ->- -- on x86_64, we have %rip for PicBaseReg, but it's not- -- a full-featured register, it can only be used for- -- rip-relative addressing.- do reg' <- getPicBaseNat (archWordFormat is32Bit)- return (Fixed (archWordFormat is32Bit) reg' nilOL)- _ ->- do- let- fmt = cmmTypeFormat (cmmRegType platform reg)- format = fmt- --- platform <- ncgPlatform <$> getConfig- return (Fixed format- (getRegisterReg platform reg)- nilOL)---getRegister' platform is32Bit (CmmRegOff r n)- = getRegister' platform is32Bit $ mangleIndexTree platform r n--getRegister' platform is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e])- = addAlignmentCheck align <$> getRegister' platform is32Bit e---- for 32-bit architectures, support some 64 -> 32 bit conversions:--- TO_W_(x), TO_W_(x >> 32)--getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32)- [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])- | is32Bit = do- ChildCode64 code rlo <- iselExpr64 x- return $ Fixed II32 (getHiVRegFromLo rlo) code--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32)- [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])- | is32Bit = do- ChildCode64 code rlo <- iselExpr64 x- return $ Fixed II32 (getHiVRegFromLo rlo) code--getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x])- | is32Bit = do- ChildCode64 code rlo <- iselExpr64 x- return $ Fixed II32 rlo code--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x])- | is32Bit = do- ChildCode64 code rlo <- iselExpr64 x- return $ Fixed II32 rlo code--getRegister' _ _ (CmmLit lit@(CmmFloat f w)) =- float_const_sse2 where- float_const_sse2- | f == 0.0 = do- let- format = floatFormat w- code dst = unitOL (XOR format (OpReg dst) (OpReg dst))- -- I don't know why there are xorpd, xorps, and pxor instructions.- -- They all appear to do the same thing --SDM- return (Any format code)-- | otherwise = do- Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit- loadFloatAmode w addr code---- catch simple cases of zero- or sign-extended load-getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _]) = do- code <- intLoadCode (MOVZxL II8) addr- return (Any II32 code)--getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _]) = do- code <- intLoadCode (MOVSxL II8) addr- return (Any II32 code)--getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _]) = do- code <- intLoadCode (MOVZxL II16) addr- return (Any II32 code)--getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _]) = do- code <- intLoadCode (MOVSxL II16) addr- return (Any II32 code)---- catch simple cases of zero- or sign-extended load-getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _])- | not is32Bit = do- code <- intLoadCode (MOVZxL II8) addr- return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _])- | not is32Bit = do- code <- intLoadCode (MOVSxL II8) addr- return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _])- | not is32Bit = do- code <- intLoadCode (MOVZxL II16) addr- return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _])- | not is32Bit = do- code <- intLoadCode (MOVSxL II16) addr- return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _])- | not is32Bit = do- code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend- return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _])- | not is32Bit = do- code <- intLoadCode (MOVSxL II32) addr- return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),- CmmLit displacement])- | not is32Bit =- return $ Any II64 (\dst -> unitOL $- LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst))--getRegister' platform is32Bit (CmmMachOp mop [x]) = -- unary MachOps- case mop of- MO_F_Neg w -> sse2NegCode w x--- MO_S_Neg w -> triv_ucode NEGI (intFormat w)- MO_Not w -> triv_ucode NOT (intFormat w)-- -- Nop conversions- MO_UU_Conv W32 W8 -> toI8Reg W32 x- MO_SS_Conv W32 W8 -> toI8Reg W32 x- MO_XX_Conv W32 W8 -> toI8Reg W32 x- MO_UU_Conv W16 W8 -> toI8Reg W16 x- MO_SS_Conv W16 W8 -> toI8Reg W16 x- MO_XX_Conv W16 W8 -> toI8Reg W16 x- MO_UU_Conv W32 W16 -> toI16Reg W32 x- MO_SS_Conv W32 W16 -> toI16Reg W32 x- MO_XX_Conv W32 W16 -> toI16Reg W32 x-- MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x- MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x- MO_XX_Conv W64 W32 | not is32Bit -> conversionNop II64 x- MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x- MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x- MO_XX_Conv W64 W16 | not is32Bit -> toI16Reg W64 x- MO_UU_Conv W64 W8 | not is32Bit -> toI8Reg W64 x- MO_SS_Conv W64 W8 | not is32Bit -> toI8Reg W64 x- MO_XX_Conv W64 W8 | not is32Bit -> toI8Reg W64 x-- MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x- MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x- MO_XX_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x-- -- widenings- MO_UU_Conv W8 W32 -> integerExtend W8 W32 MOVZxL x- MO_UU_Conv W16 W32 -> integerExtend W16 W32 MOVZxL x- MO_UU_Conv W8 W16 -> integerExtend W8 W16 MOVZxL x-- MO_SS_Conv W8 W32 -> integerExtend W8 W32 MOVSxL x- MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x- MO_SS_Conv W8 W16 -> integerExtend W8 W16 MOVSxL x-- -- We don't care about the upper bits for MO_XX_Conv, so MOV is enough. However, on 32-bit we- -- have 8-bit registers only for a few registers (as opposed to x86-64 where every register- -- has 8-bit version). So for 32-bit code, we'll just zero-extend.- MO_XX_Conv W8 W32- | is32Bit -> integerExtend W8 W32 MOVZxL x- | otherwise -> integerExtend W8 W32 MOV x- MO_XX_Conv W8 W16- | is32Bit -> integerExtend W8 W16 MOVZxL x- | otherwise -> integerExtend W8 W16 MOV x- MO_XX_Conv W16 W32 -> integerExtend W16 W32 MOV x-- MO_UU_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOVZxL x- MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x- MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x- MO_SS_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOVSxL x- MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x- MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x- -- For 32-to-64 bit zero extension, amd64 uses an ordinary movl.- -- However, we don't want the register allocator to throw it- -- away as an unnecessary reg-to-reg move, so we keep it in- -- the form of a movzl and print it as a movl later.- -- This doesn't apply to MO_XX_Conv since in this case we don't care about- -- the upper bits. So we can just use MOV.- MO_XX_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOV x- MO_XX_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOV x- MO_XX_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOV x-- MO_FF_Conv W32 W64 -> coerceFP2FP W64 x--- MO_FF_Conv W64 W32 -> coerceFP2FP W32 x-- MO_FS_Conv from to -> coerceFP2Int from to x- MO_SF_Conv from to -> coerceInt2FP from to x-- MO_V_Insert {} -> needLlvm- MO_V_Extract {} -> needLlvm- MO_V_Add {} -> needLlvm- MO_V_Sub {} -> needLlvm- MO_V_Mul {} -> needLlvm- MO_VS_Quot {} -> needLlvm- MO_VS_Rem {} -> needLlvm- MO_VS_Neg {} -> needLlvm- MO_VU_Quot {} -> needLlvm- MO_VU_Rem {} -> needLlvm- MO_VF_Insert {} -> needLlvm- MO_VF_Extract {} -> needLlvm- MO_VF_Add {} -> needLlvm- MO_VF_Sub {} -> needLlvm- MO_VF_Mul {} -> needLlvm- MO_VF_Quot {} -> needLlvm- MO_VF_Neg {} -> needLlvm-- _other -> pprPanic "getRegister" (pprMachOp mop)- where- triv_ucode :: (Format -> Operand -> Instr) -> Format -> NatM Register- triv_ucode instr format = trivialUCode format (instr format) x-- -- signed or unsigned extension.- integerExtend :: Width -> Width- -> (Format -> Operand -> Operand -> Instr)- -> CmmExpr -> NatM Register- integerExtend from to instr expr = do- (reg,e_code) <- if from == W8 then getByteReg expr- else getSomeReg expr- let- code dst =- e_code `snocOL`- instr (intFormat from) (OpReg reg) (OpReg dst)- return (Any (intFormat to) code)-- toI8Reg :: Width -> CmmExpr -> NatM Register- toI8Reg new_rep expr- = do codefn <- getAnyReg expr- return (Any (intFormat new_rep) codefn)- -- HACK: use getAnyReg to get a byte-addressable register.- -- If the source was a Fixed register, this will add the- -- mov instruction to put it into the desired destination.- -- We're assuming that the destination won't be a fixed- -- non-byte-addressable register; it won't be, because all- -- fixed registers are word-sized.-- toI16Reg = toI8Reg -- for now-- conversionNop :: Format -> CmmExpr -> NatM Register- conversionNop new_format expr- = do e_code <- getRegister' platform is32Bit expr- return (swizzleRegisterRep e_code new_format)---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- MO_F_Gt _ -> condFltReg is32Bit GTT x y- MO_F_Ge _ -> condFltReg is32Bit GE x y- -- Invert comparison condition and swap operands- -- See Note [SSE Parity Checks]- MO_F_Lt _ -> condFltReg is32Bit GTT y x- MO_F_Le _ -> condFltReg is32Bit GE y x-- MO_Eq _ -> condIntReg EQQ x y- MO_Ne _ -> condIntReg NE x y-- MO_S_Gt _ -> condIntReg GTT x y- MO_S_Ge _ -> condIntReg GE x y- MO_S_Lt _ -> condIntReg LTT x y- MO_S_Le _ -> condIntReg LE x y-- MO_U_Gt _ -> condIntReg GU x y- MO_U_Ge _ -> condIntReg GEU x y- MO_U_Lt _ -> condIntReg LU x y- MO_U_Le _ -> condIntReg LEU x y-- MO_F_Add w -> trivialFCode_sse2 w ADD x y-- MO_F_Sub w -> trivialFCode_sse2 w SUB x y-- MO_F_Quot w -> trivialFCode_sse2 w FDIV x y-- MO_F_Mul w -> trivialFCode_sse2 w MUL x y--- MO_Add rep -> add_code rep x y- MO_Sub rep -> sub_code rep x y-- MO_S_Quot rep -> div_code rep True True x y- MO_S_Rem rep -> div_code rep True False x y- MO_U_Quot rep -> div_code rep False True x y- MO_U_Rem rep -> div_code rep False False x y-- MO_S_MulMayOflo rep -> imulMayOflo rep x y-- MO_Mul W8 -> imulW8 x y- MO_Mul rep -> triv_op rep IMUL- MO_And rep -> triv_op rep AND- MO_Or rep -> triv_op rep OR- MO_Xor rep -> triv_op rep XOR-- {- Shift ops on x86s have constraints on their source, it- either has to be Imm, CL or 1- => trivialCode is not restrictive enough (sigh.)- -}- MO_Shl rep -> shift_code rep SHL x y {-False-}- MO_U_Shr rep -> shift_code rep SHR x y {-False-}- MO_S_Shr rep -> shift_code rep SAR x y {-False-}-- MO_V_Insert {} -> needLlvm- MO_V_Extract {} -> needLlvm- MO_V_Add {} -> needLlvm- MO_V_Sub {} -> needLlvm- MO_V_Mul {} -> needLlvm- MO_VS_Quot {} -> needLlvm- MO_VS_Rem {} -> needLlvm- MO_VS_Neg {} -> needLlvm- MO_VF_Insert {} -> needLlvm- MO_VF_Extract {} -> needLlvm- MO_VF_Add {} -> needLlvm- MO_VF_Sub {} -> needLlvm- MO_VF_Mul {} -> needLlvm- MO_VF_Quot {} -> needLlvm- MO_VF_Neg {} -> needLlvm-- _other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop)- where- --------------------- triv_op width instr = trivialCode width op (Just op) x y- where op = instr (intFormat width)-- -- Special case for IMUL for bytes, since the result of IMULB will be in- -- %ax, the split to %dx/%edx/%rdx and %ax/%eax/%rax happens only for wider- -- values.- imulW8 :: CmmExpr -> CmmExpr -> NatM Register- imulW8 arg_a arg_b = do- (a_reg, a_code) <- getNonClobberedReg arg_a- b_code <- getAnyReg arg_b-- let code = a_code `appOL` b_code eax `appOL`- toOL [ IMUL2 format (OpReg a_reg) ]- format = intFormat W8-- return (Fixed format eax code)--- imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register- imulMayOflo rep a b = do- (a_reg, a_code) <- getNonClobberedReg a- b_code <- getAnyReg b- let- shift_amt = case rep of- W32 -> 31- W64 -> 63- _ -> panic "shift_amt"-- format = intFormat rep- code = a_code `appOL` b_code eax `appOL`- toOL [- IMUL2 format (OpReg a_reg), -- result in %edx:%eax- SAR format (OpImm (ImmInt shift_amt)) (OpReg eax),- -- sign extend lower part- SUB format (OpReg edx) (OpReg eax)- -- compare against upper- -- eax==0 if high part == sign extended low part- ]- return (Fixed format eax code)-- --------------------- shift_code :: Width- -> (Format -> Operand -> Operand -> Instr)- -> CmmExpr- -> CmmExpr- -> NatM Register-- {- Case1: shift length as immediate -}- shift_code width instr x (CmmLit lit)- -- Handle the case of a shift larger than the width of the shifted value.- -- This is necessary since x86 applies a mask of 0x1f to the shift- -- amount, meaning that, e.g., `shr 47, $eax` will actually shift by- -- `47 & 0x1f == 15`. See #20626.- | CmmInt n _ <- lit- , n >= fromIntegral (widthInBits width)- = getRegister $ CmmLit $ CmmInt 0 width-- | otherwise = do- x_code <- getAnyReg x- let- format = intFormat width- code dst- = x_code dst `snocOL`- instr format (OpImm (litToImm lit)) (OpReg dst)- return (Any format code)-- {- Case2: shift length is complex (non-immediate)- * y must go in %ecx.- * we cannot do y first *and* put its result in %ecx, because- %ecx might be clobbered by x.- * if we do y second, then x cannot be- in a clobbered reg. Also, we cannot clobber x's reg- with the instruction itself.- * so we can either:- - do y first, put its result in a fresh tmp, then copy it to %ecx later- - do y second and put its result into %ecx. x gets placed in a fresh- tmp. This is likely to be better, because the reg alloc can- eliminate this reg->reg move here (it won't eliminate the other one,- because the move is into the fixed %ecx).- * in the case of C calls the use of ecx here can interfere with arguments.- We avoid this with the hack described in Note [Evaluate C-call- arguments before placing in destination registers]- -}- shift_code width instr x y{-amount-} = do- x_code <- getAnyReg x- let format = intFormat width- tmp <- getNewRegNat format- y_code <- getAnyReg y- let- code = x_code tmp `appOL`- y_code ecx `snocOL`- instr format (OpReg ecx) (OpReg tmp)- return (Fixed format tmp code)-- --------------------- add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register- add_code rep x (CmmLit (CmmInt y _))- | is32BitInteger y- , rep /= W8 -- LEA doesn't support byte size (#18614)- = add_int rep x y- add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y- where format = intFormat rep- -- TODO: There are other interesting patterns we want to replace- -- with a LEA, e.g. `(x + offset) + (y << shift)`.-- --------------------- sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register- sub_code rep x (CmmLit (CmmInt y _))- | is32BitInteger (-y)- , rep /= W8 -- LEA doesn't support byte size (#18614)- = add_int rep x (-y)- sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y-- -- our three-operand add instruction:- add_int width x y = do- (x_reg, x_code) <- getSomeReg x- let- format = intFormat width- imm = ImmInt (fromInteger y)- code dst- = x_code `snocOL`- LEA format- (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm))- (OpReg dst)- --- return (Any format code)-- ------------------------ -- See Note [DIV/IDIV for bytes]- div_code W8 signed quotient x y = do- let widen | signed = MO_SS_Conv W8 W16- | otherwise = MO_UU_Conv W8 W16- div_code- W16- signed- quotient- (CmmMachOp widen [x])- (CmmMachOp widen [y])-- div_code width signed quotient x y = do- (y_op, y_code) <- getRegOrMem y -- cannot be clobbered- x_code <- getAnyReg x- let- format = intFormat width- widen | signed = CLTD format- | otherwise = XOR format (OpReg edx) (OpReg edx)-- instr | signed = IDIV- | otherwise = DIV-- code = y_code `appOL`- x_code eax `appOL`- toOL [widen, instr format y_op]-- result | quotient = eax- | otherwise = edx-- return (Fixed format result code)---getRegister' _ _ (CmmLoad mem pk)- | isFloatType pk- = do- Amode addr mem_code <- getAmode mem- loadFloatAmode (typeWidth pk) addr mem_code--getRegister' _ is32Bit (CmmLoad mem pk)- | is32Bit && not (isWord64 pk)- = do- code <- intLoadCode instr mem- return (Any format code)- where- width = typeWidth pk- format = intFormat width- instr = case width of- W8 -> MOVZxL II8- _other -> MOV format- -- We always zero-extend 8-bit loads, if we- -- can't think of anything better. This is because- -- we can't guarantee access to an 8-bit variant of every register- -- (esi and edi don't have 8-bit variants), so to make things- -- simpler we do our 8-bit arithmetic with full 32-bit registers.---- Simpler memory load code on x86_64-getRegister' _ is32Bit (CmmLoad mem pk)- | not is32Bit- = do- code <- intLoadCode (MOV format) mem- return (Any format code)- where format = intFormat $ typeWidth pk--getRegister' _ is32Bit (CmmLit (CmmInt 0 width))- = let- format = intFormat width-- -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits- format1 = if is32Bit then format- else case format of- II64 -> II32- _ -> format- code dst- = unitOL (XOR format1 (OpReg dst) (OpReg dst))- in- return (Any format code)-- -- optimisation for loading small literals on x86_64: take advantage- -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit- -- instruction forms are shorter.-getRegister' platform is32Bit (CmmLit lit)- | not is32Bit, isWord64 (cmmLitType platform lit), not (isBigLit lit)- = let- imm = litToImm lit- code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst))- in- return (Any II64 code)- where- isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff- isBigLit _ = False- -- note1: not the same as (not.is32BitLit), because that checks for- -- signed literals that fit in 32 bits, but we want unsigned- -- literals here.- -- note2: all labels are small, because we're assuming the- -- small memory model (see gcc docs, -mcmodel=small).--getRegister' platform _ (CmmLit lit)- = do let format = cmmTypeFormat (cmmLitType platform lit)- imm = litToImm lit- code dst = unitOL (MOV format (OpImm imm) (OpReg dst))- return (Any format code)--getRegister' platform _ other- | isVecExpr other = needLlvm- | otherwise = pprPanic "getRegister(x86)" (pdoc platform other)---intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr- -> NatM (Reg -> InstrBlock)-intLoadCode instr mem = do- Amode src mem_code <- getAmode mem- return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst))---- Compute an expression into *any* register, adding the appropriate--- move instruction if necessary.-getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock)-getAnyReg expr = do- r <- getRegister expr- anyReg r--anyReg :: Register -> NatM (Reg -> InstrBlock)-anyReg (Any _ code) = return code-anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg dst)---- A bit like getSomeReg, but we want a reg that can be byte-addressed.--- Fixed registers might not be byte-addressable, so we make sure we've--- got a temporary, inserting an extra reg copy if necessary.-getByteReg :: CmmExpr -> NatM (Reg, InstrBlock)-getByteReg expr = do- is32Bit <- is32BitPlatform- if is32Bit- then do r <- getRegister expr- case r of- Any rep code -> do- tmp <- getNewRegNat rep- return (tmp, code tmp)- Fixed rep reg code- | isVirtualReg reg -> return (reg,code)- | otherwise -> do- tmp <- getNewRegNat rep- return (tmp, code `snocOL` reg2reg rep reg tmp)- -- ToDo: could optimise slightly by checking for- -- byte-addressable real registers, but that will- -- happen very rarely if at all.- else getSomeReg expr -- all regs are byte-addressable on x86_64---- Another variant: this time we want the result in a register that cannot--- be modified by code to evaluate an arbitrary expression.-getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock)-getNonClobberedReg expr = do- r <- getRegister expr- platform <- ncgPlatform <$> getConfig- case r of- Any rep code -> do- tmp <- getNewRegNat rep- return (tmp, code tmp)- Fixed rep reg code- -- only certain regs can be clobbered- | reg `elem` instrClobberedRegs platform- -> do- tmp <- getNewRegNat rep- return (tmp, code `snocOL` reg2reg rep reg tmp)- | otherwise ->- return (reg, code)--reg2reg :: Format -> Reg -> Reg -> Instr-reg2reg format src dst = MOV format (OpReg src) (OpReg dst)--------------------------------------------------------------------------------------- | Convert a 'CmmExpr' representing a memory address into an 'Amode'.------ An 'Amode' is a datatype representing a valid address form for the target--- (e.g. "Base + Index + disp" or immediate) and the code to compute it.-getAmode :: CmmExpr -> NatM Amode-getAmode e = do- platform <- getPlatform- let is32Bit = target32Bit platform-- case e of- CmmRegOff r n- -> getAmode $ mangleIndexTree platform r n-- CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), CmmLit displacement]- | not is32Bit- -> return $ Amode (ripRel (litToImm displacement)) nilOL-- -- This is all just ridiculous, since it carefully undoes- -- what mangleIndexTree has just done.- CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)]- | is32BitLit is32Bit lit- -- assert (rep == II32)???- -> do- (x_reg, x_code) <- getSomeReg x- let off = ImmInt (-(fromInteger i))- return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)-- CmmMachOp (MO_Add _rep) [x, CmmLit lit]- | is32BitLit is32Bit lit- -- assert (rep == II32)???- -> do- (x_reg, x_code) <- getSomeReg x- let off = litToImm lit- return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)-- -- Turn (lit1 << n + lit2) into (lit2 + lit1 << n) so it will be- -- recognised by the next rule.- CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), b@(CmmLit _)]- -> getAmode (CmmMachOp (MO_Add rep) [b,a])-- -- Matches: (x + offset) + (y << shift)- CmmMachOp (MO_Add _) [CmmRegOff x offset, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]- | shift == 0 || shift == 1 || shift == 2 || shift == 3- -> x86_complex_amode (CmmReg x) y shift (fromIntegral offset)-- CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]- | shift == 0 || shift == 1 || shift == 2 || shift == 3- -> x86_complex_amode x y shift 0-- CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Add _) [CmmMachOp (MO_Shl _)- [y, CmmLit (CmmInt shift _)], CmmLit (CmmInt offset _)]]- | shift == 0 || shift == 1 || shift == 2 || shift == 3- && is32BitInteger offset- -> x86_complex_amode x y shift offset-- CmmMachOp (MO_Add _) [x,y]- | not (isLit y) -- we already handle valid literals above.- -> x86_complex_amode x y 0 0-- CmmLit lit- | is32BitLit is32Bit lit- -> return (Amode (ImmAddr (litToImm lit) 0) nilOL)-- -- Literal with offsets too big (> 32 bits) fails during the linking phase- -- (#15570). We already handled valid literals above so we don't have to- -- test anything here.- CmmLit (CmmLabelOff l off)- -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabel l)- , CmmLit (CmmInt (fromIntegral off) W64)- ])- CmmLit (CmmLabelDiffOff l1 l2 off w)- -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabelDiffOff l1 l2 0 w)- , CmmLit (CmmInt (fromIntegral off) W64)- ])-- -- in case we can't do something better, we just compute the expression- -- and put the result in a register- _ -> do- (reg,code) <- getSomeReg e- return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code)------ | Like 'getAmode', but on 32-bit use simple register addressing--- (i.e. no index register). This stops us from running out of--- registers on x86 when using instructions such as cmpxchg, which can--- use up to three virtual registers and one fixed register.-getSimpleAmode :: Bool -> CmmExpr -> NatM Amode-getSimpleAmode is32Bit addr- | is32Bit = do- addr_code <- getAnyReg addr- config <- getConfig- addr_r <- getNewRegNat (intFormat (ncgWordWidth config))- let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0)- return $! Amode amode (addr_code addr_r)- | otherwise = getAmode addr--x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode-x86_complex_amode base index shift offset- = do (x_reg, x_code) <- getNonClobberedReg base- -- x must be in a temp, because it has to stay live over y_code- -- we could compare x_reg and y_reg and do something better here...- (y_reg, y_code) <- getSomeReg index- let- code = x_code `appOL` y_code- base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8;- n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")"- return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset)))- code)------- -------------------------------------------------------------------------------- getOperand: sometimes any operand will do.---- getNonClobberedOperand: the value of the operand will remain valid across--- the computation of an arbitrary expression, unless the expression--- is computed directly into a register which the operand refers to--- (see trivialCode where this function is used for an example).--getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)-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 return (OpImm (litToImm lit), nilOL)- else getNonClobberedOperand_generic (CmmLit lit)--getNonClobberedOperand (CmmLoad mem pk) = do- is32Bit <- is32BitPlatform- -- this logic could be simplified- -- TODO FIXME- if (if is32Bit then not (isWord64 pk) else True)- -- if 32bit and pk is at float/double/simd value- -- or if 64bit- -- this could use some eyeballs or i'll need to stare at it more later- then do- platform <- ncgPlatform <$> getConfig- Amode src mem_code <- getAmode mem- (src',save_code) <-- if (amodeCouldBeClobbered platform src)- then do- tmp <- getNewRegNat (archWordFormat is32Bit)- return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0),- unitOL (LEA (archWordFormat is32Bit)- (OpAddr src)- (OpReg tmp)))- else- return (src, nilOL)- return (OpAddr src', mem_code `appOL` save_code)- else- -- if its a word or gcptr on 32bit?- getNonClobberedOperand_generic (CmmLoad mem pk)--getNonClobberedOperand e = getNonClobberedOperand_generic e--getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)-getNonClobberedOperand_generic e = do- (reg, code) <- getNonClobberedReg e- return (OpReg reg, code)--amodeCouldBeClobbered :: Platform -> AddrMode -> Bool-amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode)--regClobbered :: Platform -> Reg -> Bool-regClobbered platform (RegReal (RealRegSingle rr)) = freeReg platform rr-regClobbered _ _ = False---- getOperand: the operand is not required to remain valid across the--- computation of an arbitrary expression.-getOperand :: CmmExpr -> NatM (Operand, InstrBlock)--getOperand (CmmLit lit) = do- use_sse2 <- sse2Enabled- if (use_sse2 && 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 return (OpImm (litToImm lit), nilOL)- else getOperand_generic (CmmLit lit)--getOperand (CmmLoad mem pk) = do- is32Bit <- is32BitPlatform- use_sse2 <- sse2Enabled- if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)- then do- Amode src mem_code <- getAmode mem- return (OpAddr src, mem_code)- else- getOperand_generic (CmmLoad mem pk)--getOperand e = getOperand_generic e--getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)-getOperand_generic e = do- (reg, code) <- getSomeReg e- return (OpReg reg, code)--isOperand :: Bool -> CmmExpr -> Bool-isOperand _ (CmmLoad _ _) = True-isOperand is32Bit (CmmLit lit) = is32BitLit is32Bit lit- || isSuitableFloatingPointLit lit-isOperand _ _ = False---- | Given a 'Register', produce a new 'Register' with an instruction block--- which will check the value for alignment. Used for @-falignment-sanitisation@.-addAlignmentCheck :: Int -> Register -> Register-addAlignmentCheck align reg =- case reg of- Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt reg)- Any fmt f -> Any fmt (\reg -> f reg `appOL` check fmt reg)- where- check :: Format -> Reg -> InstrBlock- check fmt reg =- assert (not $ isFloatFormat fmt) $- toOL [ TEST fmt (OpImm $ ImmInt $ align-1) (OpReg reg)- , JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel- ]--memConstant :: Alignment -> CmmLit -> NatM Amode-memConstant align lit = do- lbl <- getNewLabelNat- let rosection = Section ReadOnlyData lbl- config <- getConfig- platform <- getPlatform- (addr, addr_code) <- if target32Bit platform- then do dynRef <- cmmMakeDynamicReference- config- DataReference- lbl- Amode addr addr_code <- getAmode dynRef- return (addr, addr_code)- else return (ripRel (ImmCLbl lbl), nilOL)- let code =- LDATA rosection (align, CmmStaticsRaw lbl [CmmStaticLit lit])- `consOL` addr_code- return (Amode addr code)---loadFloatAmode :: Width -> AddrMode -> InstrBlock -> NatM Register-loadFloatAmode w addr addr_code = do- let format = floatFormat w- code dst = addr_code `snocOL`- MOV format (OpAddr addr) (OpReg dst)-- return (Any format code)----- if we want a floating-point literal as an operand, we can--- use it directly from memory. However, if the literal is--- zero, we're better off generating it into a register using--- xor.-isSuitableFloatingPointLit :: CmmLit -> Bool-isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0-isSuitableFloatingPointLit _ = False--getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)-getRegOrMem e@(CmmLoad mem pk) = do- is32Bit <- is32BitPlatform- use_sse2 <- sse2Enabled- if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)- then do- Amode src mem_code <- getAmode mem- return (OpAddr src, mem_code)- else do- (reg, code) <- getNonClobberedReg e- return (OpReg reg, code)-getRegOrMem e = do- (reg, code) <- getNonClobberedReg e- return (OpReg reg, code)--is32BitLit :: Bool -> CmmLit -> Bool-is32BitLit is32Bit lit- | not is32Bit = case lit of- CmmInt i W64 -> is32BitInteger i- -- assume that labels are in the range 0-2^31-1: this assumes the- -- small memory model (see gcc docs, -mcmodel=small).- CmmLabel _ -> True- -- however we can't assume that label offsets are in this range- -- (see #15570)- CmmLabelOff _ off -> is32BitInteger (fromIntegral off)- CmmLabelDiffOff _ _ off _ -> is32BitInteger (fromIntegral off)- _ -> True-is32BitLit _ _ = True------- Set up a condition code for a conditional branch.--getCondCode :: CmmExpr -> NatM CondCode---- yes, they really do seem to want exactly the same!--getCondCode (CmmMachOp mop [x, y])- =- 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- MO_F_Ge W32 -> condFltCode GE x y- -- Invert comparison condition and swap operands- -- See Note [SSE Parity Checks]- MO_F_Lt W32 -> condFltCode GTT y x- MO_F_Le W32 -> condFltCode GE y x-- MO_F_Eq W64 -> condFltCode EQQ x y- MO_F_Ne W64 -> condFltCode NE x y- MO_F_Gt W64 -> condFltCode GTT x y- MO_F_Ge W64 -> condFltCode GE x y- MO_F_Lt W64 -> condFltCode GTT y x- MO_F_Le W64 -> condFltCode GE y x-- _ -> condIntCode (machOpToCond mop) x y--getCondCode other = do- platform <- getPlatform- pprPanic "getCondCode(2)(x86,x86_64)" (pdoc platform other)--machOpToCond :: MachOp -> Cond-machOpToCond mo = case mo of- MO_Eq _ -> EQQ- MO_Ne _ -> NE- MO_S_Gt _ -> GTT- MO_S_Ge _ -> GE- MO_S_Lt _ -> LTT- MO_S_Le _ -> LE- MO_U_Gt _ -> GU- MO_U_Ge _ -> GEU- MO_U_Lt _ -> LU- MO_U_Le _ -> LEU- _other -> pprPanic "machOpToCond" (pprMachOp mo)----- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be--- passed back up the tree.--condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode-condIntCode cond x y = do is32Bit <- is32BitPlatform- condIntCode' is32Bit cond x y--condIntCode' :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode---- memory vs immediate-condIntCode' is32Bit cond (CmmLoad x pk) (CmmLit lit)- | is32BitLit is32Bit lit = do- Amode x_addr x_code <- getAmode x- let- imm = litToImm lit- code = x_code `snocOL`- CMP (cmmTypeFormat pk) (OpImm imm) (OpAddr x_addr)- --- return (CondCode False cond code)---- anything vs zero, using a mask--- TODO: Add some sanity checking!!!!-condIntCode' is32Bit cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 pk))- | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit is32Bit lit- = do- (x_reg, x_code) <- getSomeReg x- let- code = x_code `snocOL`- TEST (intFormat pk) (OpImm (ImmInteger mask)) (OpReg x_reg)- --- return (CondCode False cond code)---- anything vs zero-condIntCode' _ cond x (CmmLit (CmmInt 0 pk)) = do- (x_reg, x_code) <- getSomeReg x- let- code = x_code `snocOL`- TEST (intFormat pk) (OpReg x_reg) (OpReg x_reg)- --- return (CondCode False cond code)---- anything vs operand-condIntCode' is32Bit cond x y- | isOperand is32Bit y = do- platform <- getPlatform- (x_reg, x_code) <- getNonClobberedReg x- (y_op, y_code) <- getOperand y- let- code = x_code `appOL` y_code `snocOL`- CMP (cmmTypeFormat (cmmExprType platform x)) y_op (OpReg x_reg)- return (CondCode False cond code)--- operand vs. anything: invert the comparison so that we can use a--- single comparison instruction.- | isOperand is32Bit x- , Just revcond <- maybeFlipCond cond = do- platform <- getPlatform- (y_reg, y_code) <- getNonClobberedReg y- (x_op, x_code) <- getOperand x- let- code = y_code `appOL` x_code `snocOL`- CMP (cmmTypeFormat (cmmExprType platform x)) x_op (OpReg y_reg)- return (CondCode False revcond code)---- anything vs anything-condIntCode' _ cond x y = do- platform <- getPlatform- (y_reg, y_code) <- getNonClobberedReg y- (x_op, x_code) <- getRegOrMem x- let- code = y_code `appOL`- x_code `snocOL`- CMP (cmmTypeFormat (cmmExprType platform x)) (OpReg y_reg) x_op- return (CondCode False cond code)-------------------------------------------------------------------------------------condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode--condFltCode cond x y- = condFltCode_sse2- where--- -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be- -- an operand, but the right must be a reg. We can probably do better- -- than this general case...- condFltCode_sse2 = do- platform <- getPlatform- (x_reg, x_code) <- getNonClobberedReg x- (y_op, y_code) <- getOperand y- let- code = x_code `appOL`- y_code `snocOL`- CMP (floatFormat $ cmmExprWidth platform x) y_op (OpReg x_reg)- -- NB(1): we need to use the unsigned comparison operators on the- -- result of this comparison.- return (CondCode True (condToUnsigned cond) code)---- -------------------------------------------------------------------------------- Generating assignments---- Assignments are really at the heart of the whole code generation--- business. Almost all top-level nodes of any real importance are--- assignments, which correspond to loads, stores, or register--- transfers. If we're really lucky, some of the register transfers--- will go away, because we can use the destination register to--- complete the code generation for the right hand side. This only--- fails when the right hand side is forced into a fixed register--- (e.g. the result of a call).--assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock-assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock--assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock-assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock----- integer assignment to memory---- specific case of adding/subtracting an integer to a particular address.--- ToDo: catch other cases where we can use an operation directly on a memory--- address.-assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _,- CmmLit (CmmInt i _)])- | addr == addr2, pk /= II64 || is32BitInteger i,- Just instr <- check op- = do Amode amode code_addr <- getAmode addr- let code = code_addr `snocOL`- instr pk (OpImm (ImmInt (fromIntegral i))) (OpAddr amode)- return code- where- check (MO_Add _) = Just ADD- check (MO_Sub _) = Just SUB- check _ = Nothing- -- ToDo: more?---- general case-assignMem_IntCode pk addr src = do- is32Bit <- is32BitPlatform- Amode addr code_addr <- getAmode addr- (code_src, op_src) <- get_op_RI is32Bit src- let- code = code_src `appOL`- code_addr `snocOL`- MOV pk op_src (OpAddr addr)- -- NOTE: op_src is stable, so it will still be valid- -- after code_addr. This may involve the introduction- -- of an extra MOV to a temporary register, but we hope- -- the register allocator will get rid of it.- --- return code- where- get_op_RI :: Bool -> CmmExpr -> NatM (InstrBlock,Operand) -- code, operator- get_op_RI is32Bit (CmmLit lit) | is32BitLit is32Bit lit- = return (nilOL, OpImm (litToImm lit))- get_op_RI _ op- = do (reg,code) <- getNonClobberedReg op- return (code, OpReg reg)----- Assign; dst is a reg, rhs is mem-assignReg_IntCode pk reg (CmmLoad src _) = do- load_code <- intLoadCode (MOV pk) src- platform <- ncgPlatform <$> getConfig- return (load_code (getRegisterReg platform reg))---- dst is a reg, but src could be anything-assignReg_IntCode _ reg src = do- platform <- ncgPlatform <$> getConfig- code <- getAnyReg src- return (code (getRegisterReg platform reg))----- Floating point assignment to memory-assignMem_FltCode pk addr src = do- (src_reg, src_code) <- getNonClobberedReg src- Amode addr addr_code <- getAmode addr- let- code = src_code `appOL`- addr_code `snocOL`- MOV pk (OpReg src_reg) (OpAddr addr)-- return code---- Floating point assignment to a register/temporary-assignReg_FltCode _ reg src = do- src_code <- getAnyReg src- platform <- ncgPlatform <$> getConfig- return (src_code (getRegisterReg platform reg))---genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock--genJump (CmmLoad mem _) regs = do- Amode target code <- getAmode mem- return (code `snocOL` JMP (OpAddr target) regs)--genJump (CmmLit lit) regs =- return (unitOL (JMP (OpImm (litToImm lit)) regs))--genJump expr regs = do- (reg,code) <- getSomeReg expr- return (code `snocOL` JMP (OpReg reg) regs)----- -------------------------------------------------------------------------------- Unconditional branches--genBranch :: BlockId -> InstrBlock-genBranch = toOL . mkJumpInstr------ -------------------------------------------------------------------------------- Conditional jumps/branches--{--Conditional jumps are always to local labels, so we can use branch-instructions. We peek at the arguments to decide what kind of-comparison to do.--I386: First, we have to ensure that the condition-codes are set according to the supplied comparison operation.--}--{- Note [64-bit integer comparisons on 32-bit]- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-- When doing these comparisons there are 2 kinds of- comparisons.-- * Comparison for equality (or lack thereof)-- We use xor to check if high/low bits are- equal. Then combine the results using or and- perform a single conditional jump based on the- result.-- * Other comparisons:-- We map all other comparisons to the >= operation.- Why? Because it's easy to encode it with a single- conditional jump.-- We do this by first computing [r1_lo - r2_lo]- and use the carry flag to compute- [r1_high - r2_high - CF].-- At which point if r1 >= r2 then the result will be- positive. Otherwise negative so we can branch on this- condition.---}---genCondBranch- :: BlockId -- the source of the jump- -> BlockId -- the true branch target- -> BlockId -- the false branch target- -> CmmExpr -- the condition on which to branch- -> NatM InstrBlock -- Instructions--genCondBranch bid id false expr = do- is32Bit <- is32BitPlatform- genCondBranch' is32Bit bid id false expr---- | We return the instructions generated.-genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr- -> NatM InstrBlock---- 64-bit integer comparisons on 32-bit--- See Note [64-bit integer comparisons on 32-bit]-genCondBranch' is32Bit _bid true false (CmmMachOp mop [e1,e2])- | is32Bit, Just W64 <- maybeIntComparison mop = do-- -- The resulting registers here are both the lower part of- -- the register as well as a way to get at the higher part.- ChildCode64 code1 r1 <- iselExpr64 e1- ChildCode64 code2 r2 <- iselExpr64 e2- let cond = machOpToCond mop :: Cond-- -- we mustn't clobber r1/r2 so we use temporaries- tmp1 <- getNewRegNat II32- tmp2 <- getNewRegNat II32-- let cmpCode = intComparison cond true false r1 r2 tmp1 tmp2- return $ code1 `appOL` code2 `appOL` cmpCode-- where- intComparison :: Cond -> BlockId -> BlockId -> Reg -> Reg -> Reg -> Reg -> InstrBlock- intComparison cond true false r1_lo r2_lo tmp1 tmp2 =- case cond of- -- Impossible results of machOpToCond- ALWAYS -> panic "impossible"- NEG -> panic "impossible"- POS -> panic "impossible"- CARRY -> panic "impossible"- OFLO -> panic "impossible"- PARITY -> panic "impossible"- NOTPARITY -> panic "impossible"- -- Special case #1 x == y and x != y- EQQ -> cmpExact- NE -> cmpExact- -- [x >= y]- GE -> cmpGE- GEU -> cmpGE- -- [x > y] <==> ![y >= x]- GTT -> intComparison GE false true r2_lo r1_lo tmp1 tmp2- GU -> intComparison GEU false true r2_lo r1_lo tmp1 tmp2- -- [x <= y] <==> [y >= x]- LE -> intComparison GE true false r2_lo r1_lo tmp1 tmp2- LEU -> intComparison GEU true false r2_lo r1_lo tmp1 tmp2- -- [x < y] <==> ![x >= x]- LTT -> intComparison GE false true r1_lo r2_lo tmp1 tmp2- LU -> intComparison GEU false true r1_lo r2_lo tmp1 tmp2- where- r1_hi = getHiVRegFromLo r1_lo- r2_hi = getHiVRegFromLo r2_lo- cmpExact :: OrdList Instr- cmpExact =- toOL- [ MOV II32 (OpReg r1_hi) (OpReg tmp1)- , MOV II32 (OpReg r1_lo) (OpReg tmp2)- , XOR II32 (OpReg r2_hi) (OpReg tmp1)- , XOR II32 (OpReg r2_lo) (OpReg tmp2)- , OR II32 (OpReg tmp1) (OpReg tmp2)- , JXX cond true- , JXX ALWAYS false- ]- cmpGE = toOL- [ MOV II32 (OpReg r1_hi) (OpReg tmp1)- , CMP II32 (OpReg r2_lo) (OpReg r1_lo)- , SBB II32 (OpReg r2_hi) (OpReg tmp1)- , JXX cond true- , JXX ALWAYS false ]--genCondBranch' _ bid id false bool = do- CondCode is_float cond cond_code <- getCondCode bool- use_sse2 <- sse2Enabled- if not is_float || not use_sse2- then- return (cond_code `snocOL` JXX cond id `appOL` genBranch false)- else do- -- See Note [SSE Parity Checks]- let jmpFalse = genBranch false- code- = case cond of- NE -> or_unordered- GU -> plain_test- GEU -> plain_test- -- Use ASSERT so we don't break releases if- -- LTT/LE creep in somehow.- LTT ->- assertPpr False (ppr "Should have been turned into >")- and_ordered- LE ->- assertPpr False (ppr "Should have been turned into >=")- and_ordered- _ -> and_ordered-- plain_test = unitOL (- JXX cond id- ) `appOL` jmpFalse- or_unordered = toOL [- JXX cond id,- JXX PARITY id- ] `appOL` jmpFalse- and_ordered = toOL [- JXX PARITY false,- JXX cond id,- JXX ALWAYS false- ]- updateCfgNat (\cfg -> adjustEdgeWeight cfg (+3) bid false)- return (cond_code `appOL` code)--{- Note [Introducing cfg edges inside basic blocks]- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-- During instruction selection a statement `s`- in a block B with control of the sort: B -> C- will sometimes result in control- flow of the sort:-- ┌ < ┐- v ^- B -> B1 ┴ -> C-- as is the case for some atomic operations.-- Now to keep the CFG in sync when introducing B1 we clearly- want to insert it between B and C. However there is- a catch when we have to deal with self loops.-- We might start with code and a CFG of these forms:-- loop:- stmt1 ┌ < ┐- .... v ^- stmtX loop ┘- stmtY- ....- goto loop:-- Now we introduce B1:- ┌ ─ ─ ─ ─ ─┐- loop: │ ┌ < ┐ │- instrs v │ │ ^- .... loop ┴ B1 ┴ ┘- instrsFromX- stmtY- goto loop:-- This is simple, all outgoing edges from loop now simply- start from B1 instead and the code generator knows which- new edges it introduced for the self loop of B1.-- Disaster strikes if the statement Y follows the same pattern.- If we apply the same rule that all outgoing edges change then- we end up with:-- loop ─> B1 ─> B2 ┬─┐- │ │ └─<┤ │- │ └───<───┘ │- └───────<────────┘-- This is problematic. The edge B1->B1 is modified as expected.- However the modification is wrong!-- The assembly in this case looked like this:-- _loop:- <instrs>- _B1:- ...- cmpxchgq ...- jne _B1- <instrs>- <end _B1>- _B2:- ...- cmpxchgq ...- jne _B2- <instrs>- jmp loop-- There is no edge _B2 -> _B1 here. It's still a self loop onto _B1.-- The problem here is that really B1 should be two basic blocks.- Otherwise we have control flow in the *middle* of a basic block.- A contradiction!-- So to account for this we add yet another basic block marker:-- _B:- <instrs>- _B1:- ...- cmpxchgq ...- jne _B1- jmp _B1'- _B1':- <instrs>- <end _B1>- _B2:- ...-- Now when inserting B2 we will only look at the outgoing edges of B1' and- everything will work out nicely.-- You might also wonder why we don't insert jumps at the end of _B1'. There is- no way another block ends up jumping to the labels _B1 or _B2 since they are- essentially invisible to other blocks. View them as control flow labels local- to the basic block if you'd like.-- Not doing this ultimately caused (part 2 of) #17334.--}----- -------------------------------------------------------------------------------- Generating C calls---- Now the biggest nightmare---calls. Most of the nastiness is buried in--- @get_arg@, which moves the arguments to the correct registers/stack--- locations. Apart from that, the code is easy.------ (If applicable) Do not fill the delay slots here; you will confuse the--- register allocator.------ See Note [Keeping track of the current block] for information why we need--- to take/return a block id.--genCCall- :: Bool -- 32 bit platform?- -> ForeignTarget -- function to call- -> [CmmFormal] -- where to put the result- -> [CmmActual] -- arguments (of mixed type)- -> BlockId -- The block we are in- -> NatM (InstrBlock, Maybe BlockId)---- First we deal with cases which might introduce new blocks in the stream.--genCCall is32Bit (PrimTarget (MO_AtomicRMW width amop))- [dst] [addr, n] bid = do- Amode amode addr_code <-- if amop `elem` [AMO_Add, AMO_Sub]- then getAmode addr- else getSimpleAmode is32Bit addr -- See genCCall for MO_Cmpxchg- arg <- getNewRegNat format- arg_code <- getAnyReg n- platform <- ncgPlatform <$> getConfig-- let dst_r = getRegisterReg platform (CmmLocal dst)- (code, lbl) <- op_code dst_r arg amode- return (addr_code `appOL` arg_code arg `appOL` code, Just lbl)- where- -- Code for the operation- op_code :: Reg -- Destination reg- -> Reg -- Register containing argument- -> AddrMode -- Address of location to mutate- -> NatM (OrdList Instr,BlockId) -- TODO: Return Maybe BlockId- op_code dst_r arg amode = case amop of- -- In the common case where dst_r is a virtual register the- -- final move should go away, because it's the last use of arg- -- and the first use of dst_r.- AMO_Add -> return $ (toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode))- , MOV format (OpReg arg) (OpReg dst_r)- ], bid)- AMO_Sub -> return $ (toOL [ NEGI format (OpReg arg)- , LOCK (XADD format (OpReg arg) (OpAddr amode))- , MOV format (OpReg arg) (OpReg dst_r)- ], bid)- -- In these cases we need a new block id, and have to return it so- -- that later instruction selection can reference it.- AMO_And -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst)- AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst- , NOT format dst- ])- AMO_Or -> cmpxchg_code (\ src dst -> unitOL $ OR format src dst)- AMO_Xor -> cmpxchg_code (\ src dst -> unitOL $ XOR format src dst)- where- -- Simulate operation that lacks a dedicated instruction using- -- cmpxchg.- cmpxchg_code :: (Operand -> Operand -> OrdList Instr)- -> NatM (OrdList Instr, BlockId)- cmpxchg_code instrs = do- lbl1 <- getBlockIdNat- lbl2 <- getBlockIdNat- tmp <- getNewRegNat format-- --Record inserted blocks- -- We turn A -> B into A -> A' -> A'' -> B- -- with a self loop on A'.- addImmediateSuccessorNat bid lbl1- addImmediateSuccessorNat lbl1 lbl2- updateCfgNat (addWeightEdge lbl1 lbl1 0)-- return $ (toOL- [ MOV format (OpAddr amode) (OpReg eax)- , JXX ALWAYS lbl1- , NEWBLOCK lbl1- -- Keep old value so we can return it:- , MOV format (OpReg eax) (OpReg dst_r)- , MOV format (OpReg eax) (OpReg tmp)- ]- `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL- [ LOCK (CMPXCHG format (OpReg tmp) (OpAddr amode))- , JXX NE lbl1- -- See Note [Introducing cfg edges inside basic blocks]- -- why this basic block is required.- , JXX ALWAYS lbl2- , NEWBLOCK lbl2- ],- lbl2)- format = intFormat width--genCCall is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid- | is32Bit, width == W64 = do- ChildCode64 vcode rlo <- iselExpr64 src- platform <- ncgPlatform <$> getConfig- let rhi = getHiVRegFromLo rlo- dst_r = getRegisterReg platform (CmmLocal dst)- lbl1 <- getBlockIdNat- lbl2 <- getBlockIdNat- let format = if width == W8 then II16 else intFormat width- tmp_r <- getNewRegNat format-- -- New CFG Edges:- -- bid -> lbl2- -- bid -> lbl1 -> lbl2- -- We also changes edges originating at bid to start at lbl2 instead.- weights <- getCfgWeights- updateCfgNat (addWeightEdge bid lbl1 110 .- addWeightEdge lbl1 lbl2 110 .- addImmediateSuccessor weights bid lbl2)-- -- The following instruction sequence corresponds to the pseudo-code- --- -- if (src) {- -- dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32);- -- } else {- -- dst = 64;- -- }- let !instrs = vcode `appOL` toOL- ([ MOV II32 (OpReg rhi) (OpReg tmp_r)- , OR II32 (OpReg rlo) (OpReg tmp_r)- , MOV II32 (OpImm (ImmInt 64)) (OpReg dst_r)- , JXX EQQ lbl2- , JXX ALWAYS lbl1-- , NEWBLOCK lbl1- , BSF II32 (OpReg rhi) dst_r- , ADD II32 (OpImm (ImmInt 32)) (OpReg dst_r)- , BSF II32 (OpReg rlo) tmp_r- , CMOV NE II32 (OpReg tmp_r) dst_r- , JXX ALWAYS lbl2-- , NEWBLOCK lbl2- ])- return (instrs, Just lbl2)-- | otherwise = do- code_src <- getAnyReg src- config <- getConfig- let platform = ncgPlatform config- let dst_r = getRegisterReg platform (CmmLocal dst)- if ncgBmiVersion config >= Just BMI2- then do- src_r <- getNewRegNat (intFormat width)- let instrs = appOL (code_src src_r) $ case width of- W8 -> toOL- [ OR II32 (OpImm (ImmInteger 0xFFFFFF00)) (OpReg src_r)- , TZCNT II32 (OpReg src_r) dst_r- ]- W16 -> toOL- [ TZCNT II16 (OpReg src_r) dst_r- , MOVZxL II16 (OpReg dst_r) (OpReg dst_r)- ]- _ -> unitOL $ TZCNT (intFormat width) (OpReg src_r) dst_r- return (instrs, Nothing)- else do- -- The following insn sequence makes sure 'ctz 0' has a defined value.- -- starting with Haswell, one could use the TZCNT insn instead.- let format = if width == W8 then II16 else intFormat width- src_r <- getNewRegNat format- tmp_r <- getNewRegNat format- let !instrs = code_src src_r `appOL` toOL- ([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] ++- [ BSF format (OpReg src_r) tmp_r- , MOV II32 (OpImm (ImmInt bw)) (OpReg dst_r)- , CMOV NE format (OpReg tmp_r) dst_r- ]) -- NB: We don't need to zero-extend the result for the- -- W8/W16 cases because the 'MOV' insn already- -- took care of implicitly clearing the upper bits- return (instrs, Nothing)- where- bw = widthInBits width--genCCall bits mop dst args bid = do- config <- getConfig- instr <- genCCall' config bits mop dst args bid- return (instr, Nothing)---- genCCall' handles cases not introducing new code blocks.-genCCall'- :: NCGConfig- -> Bool -- 32 bit platform?- -> ForeignTarget -- function to call- -> [CmmFormal] -- where to put the result- -> [CmmActual] -- arguments (of mixed type)- -> BlockId -- The block we are in- -> NatM InstrBlock---- Unroll memcpy calls if the number of bytes to copy isn't too--- large. Otherwise, call C's memcpy.-genCCall' config _ (PrimTarget (MO_Memcpy align)) _- [dst, src, CmmLit (CmmInt n _)] _- | fromInteger insns <= ncgInlineThresholdMemcpy config = do- code_dst <- getAnyReg dst- dst_r <- getNewRegNat format- code_src <- getAnyReg src- src_r <- getNewRegNat format- tmp_r <- getNewRegNat format- return $ code_dst dst_r `appOL` code_src src_r `appOL`- go dst_r src_r tmp_r (fromInteger n)- where- platform = ncgPlatform config- -- The number of instructions we will generate (approx). We need 2- -- instructions per move.- insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes)-- maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported- effectiveAlignment = min (alignmentOf align) maxAlignment- format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment-- -- The size of each move, in bytes.- sizeBytes :: Integer- sizeBytes = fromIntegral (formatInBytes format)-- go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr- go dst src tmp i- | i >= sizeBytes =- unitOL (MOV format (OpAddr src_addr) (OpReg tmp)) `appOL`- unitOL (MOV format (OpReg tmp) (OpAddr dst_addr)) `appOL`- go dst src tmp (i - sizeBytes)- -- Deal with remaining bytes.- | i >= 4 = -- Will never happen on 32-bit- unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL`- unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL`- go dst src tmp (i - 4)- | i >= 2 =- unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL`- unitOL (MOV II16 (OpReg tmp) (OpAddr dst_addr)) `appOL`- go dst src tmp (i - 2)- | i >= 1 =- unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL`- unitOL (MOV II8 (OpReg tmp) (OpAddr dst_addr)) `appOL`- go dst src tmp (i - 1)- | otherwise = nilOL- where- src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone- (ImmInteger (n - i))- dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone- (ImmInteger (n - i))--genCCall' config _ (PrimTarget (MO_Memset align)) _- [dst,- CmmLit (CmmInt c _),- CmmLit (CmmInt n _)]- _- | fromInteger insns <= ncgInlineThresholdMemset config = do- code_dst <- getAnyReg dst- dst_r <- getNewRegNat format- if format == II64 && n >= 8 then do- code_imm8byte <- getAnyReg (CmmLit (CmmInt c8 W64))- imm8byte_r <- getNewRegNat II64- return $ code_dst dst_r `appOL`- code_imm8byte imm8byte_r `appOL`- go8 dst_r imm8byte_r (fromInteger n)- else- return $ code_dst dst_r `appOL`- go4 dst_r (fromInteger n)- where- platform = ncgPlatform config- maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported- effectiveAlignment = min (alignmentOf align) maxAlignment- format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment- c2 = c `shiftL` 8 .|. c- c4 = c2 `shiftL` 16 .|. c2- c8 = c4 `shiftL` 32 .|. c4-- -- The number of instructions we will generate (approx). We need 1- -- instructions per move.- insns = (n + sizeBytes - 1) `div` sizeBytes-- -- The size of each move, in bytes.- sizeBytes :: Integer- sizeBytes = fromIntegral (formatInBytes format)-- -- Depending on size returns the widest MOV instruction and its- -- width.- gen4 :: AddrMode -> Integer -> (InstrBlock, Integer)- gen4 addr size- | size >= 4 =- (unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr addr)), 4)- | size >= 2 =- (unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr addr)), 2)- | size >= 1 =- (unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr addr)), 1)- | otherwise = (nilOL, 0)-- -- Generates a 64-bit wide MOV instruction from REG to MEM.- gen8 :: AddrMode -> Reg -> InstrBlock- gen8 addr reg8byte =- unitOL (MOV format (OpReg reg8byte) (OpAddr addr))-- -- Unrolls memset when the widest MOV is <= 4 bytes.- go4 :: Reg -> Integer -> InstrBlock- go4 dst left =- if left <= 0 then nilOL- else curMov `appOL` go4 dst (left - curWidth)- where- possibleWidth = minimum [left, sizeBytes]- dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))- (curMov, curWidth) = gen4 dst_addr possibleWidth-- -- Unrolls memset when the widest MOV is 8 bytes (thus another Reg- -- argument). Falls back to go4 when all 8 byte moves are- -- exhausted.- go8 :: Reg -> Reg -> Integer -> InstrBlock- go8 dst reg8byte left =- if possibleWidth >= 8 then- let curMov = gen8 dst_addr reg8byte- in curMov `appOL` go8 dst reg8byte (left - 8)- else go4 dst left- where- possibleWidth = minimum [left, sizeBytes]- dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))--genCCall' _ _ (PrimTarget MO_ReadBarrier) _ _ _ = return nilOL-genCCall' _ _ (PrimTarget MO_WriteBarrier) _ _ _ = return nilOL- -- barriers compile to no code on x86/x86-64;- -- we keep it this long in order to prevent earlier optimisations.--genCCall' _ _ (PrimTarget MO_Touch) _ _ _ = return nilOL--genCCall' _ is32bit (PrimTarget (MO_Prefetch_Data n )) _ [src] _ =- case n of- 0 -> genPrefetch src $ PREFETCH NTA format- 1 -> genPrefetch src $ PREFETCH Lvl2 format- 2 -> genPrefetch src $ PREFETCH Lvl1 format- 3 -> genPrefetch src $ PREFETCH Lvl0 format- l -> panic $ "unexpected prefetch level in genCCall MO_Prefetch_Data: " ++ (show l)- -- the c / llvm prefetch convention is 0, 1, 2, and 3- -- the x86 corresponding names are : NTA, 2 , 1, and 0- where- format = archWordFormat is32bit- -- need to know what register width for pointers!- genPrefetch inRegSrc prefetchCTor =- do- code_src <- getAnyReg inRegSrc- src_r <- getNewRegNat format- return $ code_src src_r `appOL`- (unitOL (prefetchCTor (OpAddr- ((AddrBaseIndex (EABaseReg src_r ) EAIndexNone (ImmInt 0)))) ))- -- prefetch always takes an address--genCCall' _ is32Bit (PrimTarget (MO_BSwap width)) [dst] [src] _ = do- platform <- ncgPlatform <$> getConfig- let dst_r = getRegisterReg platform (CmmLocal dst)- case width of- W64 | is32Bit -> do- ChildCode64 vcode rlo <- iselExpr64 src- let dst_rhi = getHiVRegFromLo dst_r- rhi = getHiVRegFromLo rlo- return $ vcode `appOL`- toOL [ MOV II32 (OpReg rlo) (OpReg dst_rhi),- MOV II32 (OpReg rhi) (OpReg dst_r),- BSWAP II32 dst_rhi,- BSWAP II32 dst_r ]- W16 -> do code_src <- getAnyReg src- return $ code_src dst_r `appOL`- unitOL (BSWAP II32 dst_r) `appOL`- unitOL (SHR II32 (OpImm $ ImmInt 16) (OpReg dst_r))- _ -> do code_src <- getAnyReg src- return $ code_src dst_r `appOL` unitOL (BSWAP format dst_r)- where- format = intFormat width--genCCall' config is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]- args@[src] bid = do- sse4_2 <- sse4_2Enabled- let platform = ncgPlatform config- if sse4_2- then do code_src <- getAnyReg src- src_r <- getNewRegNat format- let dst_r = getRegisterReg platform (CmmLocal dst)- return $ code_src src_r `appOL`- (if width == W8 then- -- The POPCNT instruction doesn't take a r/m8- unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL`- unitOL (POPCNT II16 (OpReg src_r) dst_r)- else- unitOL (POPCNT format (OpReg src_r) dst_r)) `appOL`- (if width == W8 || width == W16 then- -- We used a 16-bit destination register above,- -- so zero-extend- unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))- else nilOL)- else do- targetExpr <- cmmMakeDynamicReference config- CallReference lbl- let target = ForeignTarget targetExpr (ForeignConvention CCallConv- [NoHint] [NoHint]- CmmMayReturn)- genCCall' config is32Bit target dest_regs args bid- where- format = intFormat width- lbl = mkCmmCodeLabel primUnitId (popCntLabel width)--genCCall' config is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst]- args@[src, mask] bid = do- let platform = ncgPlatform config- if ncgBmiVersion config >= Just BMI2- then do code_src <- getAnyReg src- code_mask <- getAnyReg mask- src_r <- getNewRegNat format- mask_r <- getNewRegNat format- let dst_r = getRegisterReg platform (CmmLocal dst)- return $ code_src src_r `appOL` code_mask mask_r `appOL`- -- PDEP only supports > 32 bit args- ( if width == W8 || width == W16 then- toOL- [ MOVZxL format (OpReg src_r ) (OpReg src_r )- , MOVZxL format (OpReg mask_r) (OpReg mask_r)- , PDEP II32 (OpReg mask_r) (OpReg src_r ) dst_r- , MOVZxL format (OpReg dst_r) (OpReg dst_r) -- Truncate to op width- ]- else- unitOL (PDEP format (OpReg mask_r) (OpReg src_r) dst_r)- )- else do- targetExpr <- cmmMakeDynamicReference config- CallReference lbl- let target = ForeignTarget targetExpr (ForeignConvention CCallConv- [NoHint] [NoHint]- CmmMayReturn)- genCCall' config is32Bit target dest_regs args bid- where- format = intFormat width- lbl = mkCmmCodeLabel primUnitId (pdepLabel width)--genCCall' config is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst]- args@[src, mask] bid = do- let platform = ncgPlatform config- if ncgBmiVersion config >= Just BMI2- then do code_src <- getAnyReg src- code_mask <- getAnyReg mask- src_r <- getNewRegNat format- mask_r <- getNewRegNat format- let dst_r = getRegisterReg platform (CmmLocal dst)- return $ code_src src_r `appOL` code_mask mask_r `appOL`- (if width == W8 || width == W16 then- -- The PEXT instruction doesn't take a r/m8 or 16- toOL- [ MOVZxL format (OpReg src_r ) (OpReg src_r )- , MOVZxL format (OpReg mask_r) (OpReg mask_r)- , PEXT II32 (OpReg mask_r) (OpReg src_r ) dst_r- , MOVZxL format (OpReg dst_r) (OpReg dst_r) -- Truncate to op width- ]- else- unitOL (PEXT format (OpReg mask_r) (OpReg src_r) dst_r)- )- else do- targetExpr <- cmmMakeDynamicReference config- CallReference lbl- let target = ForeignTarget targetExpr (ForeignConvention CCallConv- [NoHint] [NoHint]- CmmMayReturn)- genCCall' config is32Bit target dest_regs args bid- where- format = intFormat width- lbl = mkCmmCodeLabel primUnitId (pextLabel width)--genCCall' config is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] bid- | is32Bit && width == W64 = do- -- Fallback to `hs_clz64` on i386- targetExpr <- cmmMakeDynamicReference config CallReference lbl- let target = ForeignTarget targetExpr (ForeignConvention CCallConv- [NoHint] [NoHint]- CmmMayReturn)- genCCall' config is32Bit target dest_regs args bid-- | otherwise = do- code_src <- getAnyReg src- config <- getConfig- let platform = ncgPlatform config- let dst_r = getRegisterReg platform (CmmLocal dst)- if ncgBmiVersion config >= Just BMI2- then do- src_r <- getNewRegNat (intFormat width)- return $ appOL (code_src src_r) $ case width of- W8 -> toOL- [ MOVZxL II8 (OpReg src_r) (OpReg src_r) -- zero-extend to 32 bit- , LZCNT II32 (OpReg src_r) dst_r -- lzcnt with extra 24 zeros- , SUB II32 (OpImm (ImmInt 24)) (OpReg dst_r) -- compensate for extra zeros- ]- W16 -> toOL- [ LZCNT II16 (OpReg src_r) dst_r- , MOVZxL II16 (OpReg dst_r) (OpReg dst_r) -- zero-extend from 16 bit- ]- _ -> unitOL (LZCNT (intFormat width) (OpReg src_r) dst_r)- else do- let format = if width == W8 then II16 else intFormat width- src_r <- getNewRegNat format- tmp_r <- getNewRegNat format- return $ code_src src_r `appOL` toOL- ([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] ++- [ BSR format (OpReg src_r) tmp_r- , MOV II32 (OpImm (ImmInt (2*bw-1))) (OpReg dst_r)- , CMOV NE format (OpReg tmp_r) dst_r- , XOR format (OpImm (ImmInt (bw-1))) (OpReg dst_r)- ]) -- NB: We don't need to zero-extend the result for the- -- W8/W16 cases because the 'MOV' insn already- -- took care of implicitly clearing the upper bits- where- bw = widthInBits width- lbl = mkCmmCodeLabel primUnitId (clzLabel width)--genCCall' config is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do- targetExpr <- cmmMakeDynamicReference config- CallReference lbl- let target = ForeignTarget targetExpr (ForeignConvention CCallConv- [NoHint] [NoHint]- CmmMayReturn)- genCCall' config is32Bit target dest_regs args bid- where- lbl = mkCmmCodeLabel primUnitId (word2FloatLabel width)--genCCall' _ _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] _ = do- load_code <- intLoadCode (MOV (intFormat width)) addr- platform <- ncgPlatform <$> getConfig-- return (load_code (getRegisterReg platform (CmmLocal dst)))--genCCall' _ _ (PrimTarget (MO_AtomicWrite width)) [] [addr, val] _ = do- code <- assignMem_IntCode (intFormat width) addr val- return $ code `snocOL` MFENCE--genCCall' _ is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] _- -- On x86 we don't have enough registers to use cmpxchg with a- -- complicated addressing mode, so on that architecture we- -- pre-compute the address first.- | not (is32Bit && width == W64) = do- Amode amode addr_code <- getSimpleAmode is32Bit addr- newval <- getNewRegNat format- newval_code <- getAnyReg new- oldval <- getNewRegNat format- oldval_code <- getAnyReg old- platform <- getPlatform- let dst_r = getRegisterReg platform (CmmLocal dst)- code = toOL- [ MOV format (OpReg oldval) (OpReg eax)- , LOCK (CMPXCHG format (OpReg newval) (OpAddr amode))- , MOV format (OpReg eax) (OpReg dst_r)- ]- return $ addr_code `appOL` newval_code newval `appOL` oldval_code oldval- `appOL` code- where- format = intFormat width--genCCall' config is32Bit (PrimTarget (MO_Xchg width)) [dst] [addr, value] _- | (is32Bit && width == W64) = panic "gencCall: 64bit atomic exchange not supported on 32bit platforms"- | otherwise = do- let dst_r = getRegisterReg platform (CmmLocal dst)- Amode amode addr_code <- getSimpleAmode is32Bit addr- (newval, newval_code) <- getSomeReg value- -- Copy the value into the target register, perform the exchange.- let code = toOL- [ MOV format (OpReg newval) (OpReg dst_r)- -- On X86 xchg implies a lock prefix if we use a memory argument.- -- so this is atomic.- , XCHG format (OpAddr amode) dst_r- ]- return $ addr_code `appOL` newval_code `appOL` code- where- format = intFormat width- platform = ncgPlatform config--genCCall' _ is32Bit target dest_regs args bid = do- platform <- ncgPlatform <$> getConfig- case (target, dest_regs) of- -- void return type prim op- (PrimTarget op, []) ->- outOfLineCmmOp bid op Nothing args- -- we only cope with a single result for foreign calls- (PrimTarget op, [r]) -> case op of- MO_F32_Fabs -> case args of- [x] -> sse2FabsCode W32 x- _ -> panic "genCCall: Wrong number of arguments for fabs"- MO_F64_Fabs -> case args of- [x] -> sse2FabsCode W64 x- _ -> panic "genCCall: Wrong number of arguments for fabs"-- MO_F32_Sqrt -> actuallyInlineSSE2Op (\fmt r -> SQRT fmt (OpReg r)) FF32 args- MO_F64_Sqrt -> actuallyInlineSSE2Op (\fmt r -> SQRT fmt (OpReg r)) FF64 args- _other_op -> outOfLineCmmOp bid op (Just r) args-- where- actuallyInlineSSE2Op = actuallyInlineFloatOp'-- actuallyInlineFloatOp' instr format [x]- = do res <- trivialUFCode format (instr format) x- any <- anyReg res- return (any (getRegisterReg platform (CmmLocal r)))-- actuallyInlineFloatOp' _ _ args- = panic $ "genCCall.actuallyInlineFloatOp': bad number of arguments! ("- ++ show (length args) ++ ")"-- sse2FabsCode :: Width -> CmmExpr -> NatM InstrBlock- sse2FabsCode w x = do- let fmt = floatFormat w- x_code <- getAnyReg x- let- const | FF32 <- fmt = CmmInt 0x7fffffff W32- | otherwise = CmmInt 0x7fffffffffffffff W64- Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const- tmp <- getNewRegNat fmt- let- code dst = x_code dst `appOL` amode_code `appOL` toOL [- MOV fmt (OpAddr amode) (OpReg tmp),- AND fmt (OpReg tmp) (OpReg dst)- ]-- return $ code (getRegisterReg platform (CmmLocal r))-- (PrimTarget (MO_S_QuotRem width), _) -> divOp1 platform True width dest_regs args- (PrimTarget (MO_U_QuotRem width), _) -> divOp1 platform False width dest_regs args- (PrimTarget (MO_U_QuotRem2 width), _) -> divOp2 platform False width dest_regs args- (PrimTarget (MO_Add2 width), [res_h, res_l]) ->- case args of- [arg_x, arg_y] ->- do hCode <- getAnyReg (CmmLit (CmmInt 0 width))- let format = intFormat width- lCode <- anyReg =<< trivialCode width (ADD_CC format)- (Just (ADD_CC format)) arg_x arg_y- let reg_l = getRegisterReg platform (CmmLocal res_l)- reg_h = getRegisterReg platform (CmmLocal res_h)- code = hCode reg_h `appOL`- lCode reg_l `snocOL`- ADC format (OpImm (ImmInteger 0)) (OpReg reg_h)- return code- _ -> panic "genCCall: Wrong number of arguments/results for add2"- (PrimTarget (MO_AddWordC width), [res_r, res_c]) ->- addSubIntC platform ADD_CC (const Nothing) CARRY width res_r res_c args- (PrimTarget (MO_SubWordC width), [res_r, res_c]) ->- addSubIntC platform SUB_CC (const Nothing) CARRY width res_r res_c args- (PrimTarget (MO_AddIntC width), [res_r, res_c]) ->- addSubIntC platform ADD_CC (Just . ADD_CC) OFLO width res_r res_c args- (PrimTarget (MO_SubIntC width), [res_r, res_c]) ->- addSubIntC platform SUB_CC (const Nothing) OFLO width res_r res_c args- (PrimTarget (MO_U_Mul2 width), [res_h, res_l]) ->- case args of- [arg_x, arg_y] ->- do (y_reg, y_code) <- getRegOrMem arg_y- x_code <- getAnyReg arg_x- let format = intFormat width- reg_h = getRegisterReg platform (CmmLocal res_h)- reg_l = getRegisterReg platform (CmmLocal res_l)- code = y_code `appOL`- x_code rax `appOL`- toOL [MUL2 format y_reg,- MOV format (OpReg rdx) (OpReg reg_h),- MOV format (OpReg rax) (OpReg reg_l)]- return code- _ -> panic "genCCall: Wrong number of arguments/results for mul2"- (PrimTarget (MO_S_Mul2 width), [res_c, res_h, res_l]) ->- case args of- [arg_x, arg_y] ->- do (y_reg, y_code) <- getRegOrMem arg_y- x_code <- getAnyReg arg_x- reg_tmp <- getNewRegNat II8- let format = intFormat width- reg_h = getRegisterReg platform (CmmLocal res_h)- reg_l = getRegisterReg platform (CmmLocal res_l)- reg_c = getRegisterReg platform (CmmLocal res_c)- code = y_code `appOL`- x_code rax `appOL`- toOL [ IMUL2 format y_reg- , MOV format (OpReg rdx) (OpReg reg_h)- , MOV format (OpReg rax) (OpReg reg_l)- , SETCC CARRY (OpReg reg_tmp)- , MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)- ]- return code- _ -> panic "genCCall: Wrong number of arguments/results for imul2"-- _ -> do- (instrs0, args') <- evalArgs bid args- instrs1 <- if is32Bit- then genCCall32' target dest_regs args'- else genCCall64' target dest_regs args'- return (instrs0 `appOL` instrs1)-- where divOp1 platform signed width results [arg_x, arg_y]- = divOp platform signed width results Nothing arg_x arg_y- divOp1 _ _ _ _ _- = panic "genCCall: Wrong number of arguments for divOp1"- divOp2 platform signed width results [arg_x_high, arg_x_low, arg_y]- = divOp platform signed width results (Just arg_x_high) arg_x_low arg_y- divOp2 _ _ _ _ _- = panic "genCCall: Wrong number of arguments for divOp2"-- -- See Note [DIV/IDIV for bytes]- divOp platform signed W8 [res_q, res_r] m_arg_x_high arg_x_low arg_y =- let widen | signed = MO_SS_Conv W8 W16- | otherwise = MO_UU_Conv W8 W16- arg_x_low_16 = CmmMachOp widen [arg_x_low]- arg_y_16 = CmmMachOp widen [arg_y]- m_arg_x_high_16 = (\p -> CmmMachOp widen [p]) <$> m_arg_x_high- in divOp- platform signed W16 [res_q, res_r]- m_arg_x_high_16 arg_x_low_16 arg_y_16-- divOp platform signed width [res_q, res_r]- m_arg_x_high arg_x_low arg_y- = do let format = intFormat width- reg_q = getRegisterReg platform (CmmLocal res_q)- reg_r = getRegisterReg platform (CmmLocal res_r)- widen | signed = CLTD format- | otherwise = XOR format (OpReg rdx) (OpReg rdx)- instr | signed = IDIV- | otherwise = DIV- (y_reg, y_code) <- getRegOrMem arg_y- x_low_code <- getAnyReg arg_x_low- x_high_code <- case m_arg_x_high of- Just arg_x_high ->- getAnyReg arg_x_high- Nothing ->- return $ const $ unitOL widen- return $ y_code `appOL`- x_low_code rax `appOL`- x_high_code rdx `appOL`- toOL [instr format y_reg,- MOV format (OpReg rax) (OpReg reg_q),- MOV format (OpReg rdx) (OpReg reg_r)]- divOp _ _ _ _ _ _ _- = panic "genCCall: Wrong number of results for divOp"-- addSubIntC platform instr mrevinstr cond width- res_r res_c [arg_x, arg_y]- = do let format = intFormat width- rCode <- anyReg =<< trivialCode width (instr format)- (mrevinstr format) arg_x arg_y- reg_tmp <- getNewRegNat II8- let reg_c = getRegisterReg platform (CmmLocal res_c)- reg_r = getRegisterReg platform (CmmLocal res_r)- code = rCode reg_r `snocOL`- SETCC cond (OpReg reg_tmp) `snocOL`- MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)-- return code- addSubIntC _ _ _ _ _ _ _ _- = panic "genCCall: Wrong number of arguments/results for addSubIntC"--{--Note [Evaluate C-call arguments before placing in destination registers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--When producing code for C calls we must take care when placing arguments-in their final registers. Specifically, we must ensure that temporary register-usage due to evaluation of one argument does not clobber a register in which we-already placed a previous argument (e.g. as the code generation logic for-MO_Shl can clobber %rcx due to x86 instruction limitations).--This is precisely what happened in #18527. Consider this C--:-- (result::I64) = call "ccall" doSomething(_s2hp::I64, 2244, _s2hq::I64, _s2hw::I64 | (1 << _s2hz::I64));--Here we are calling the C function `doSomething` with three arguments, the last-involving a non-trivial expression involving MO_Shl. In this case the NCG could-naively generate the following assembly (where $tmp denotes some temporary-register and $argN denotes the register for argument N, as dictated by the-platform's calling convention):-- mov _s2hp, $arg1 # place first argument- mov _s2hq, $arg2 # place second argument-- # Compute 1 << _s2hz- mov _s2hz, %rcx- shl %cl, $tmp-- # Compute (_s2hw | (1 << _s2hz))- mov _s2hw, $arg3- or $tmp, $arg3-- # Perform the call- call func--This code is outright broken on Windows which assigns $arg1 to %rcx. This means-that the evaluation of the last argument clobbers the first argument.--To avoid this we use a rather awful hack: when producing code for a C call with-at least one non-trivial argument, we first evaluate all of the arguments into-local registers before moving them into their final calling-convention-defined-homes. This is performed by 'evalArgs'. Here we define "non-trivial" to be an-expression which might contain a MachOp since these are the only cases which-might clobber registers. Furthermore, we use a conservative approximation of-this condition (only looking at the top-level of CmmExprs) to avoid spending-too much effort trying to decide whether we want to take the fast path.--Note that this hack *also* applies to calls to out-of-line PrimTargets (which-are lowered via a C call) since outOfLineCmmOp produces the call via-(stmtToInstrs (CmmUnsafeForeignCall ...)), which will ultimately end up-back in genCCall{32,64}.--}---- | See Note [Evaluate C-call arguments before placing in destination registers]-evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual])-evalArgs bid actuals- | any mightContainMachOp actuals = do- regs_blks <- mapM evalArg actuals- return (concatOL $ map fst regs_blks, map snd regs_blks)- | otherwise = return (nilOL, actuals)- where- mightContainMachOp (CmmReg _) = False- mightContainMachOp (CmmRegOff _ _) = False- mightContainMachOp (CmmLit _) = False- mightContainMachOp _ = True-- evalArg :: CmmActual -> NatM (InstrBlock, CmmExpr)- evalArg actual = do- platform <- getPlatform- lreg <- newLocalReg $ cmmExprType platform actual- (instrs, bid1) <- stmtToInstrs bid $ CmmAssign (CmmLocal lreg) actual- -- The above assignment shouldn't change the current block- massert (isNothing bid1)- return (instrs, CmmReg $ CmmLocal lreg)-- newLocalReg :: CmmType -> NatM LocalReg- newLocalReg ty = LocalReg <$> getUniqueM <*> pure ty---- Note [DIV/IDIV for bytes]------ IDIV reminder:--- Size Dividend Divisor Quotient Remainder--- byte %ax r/m8 %al %ah--- word %dx:%ax r/m16 %ax %dx--- dword %edx:%eax r/m32 %eax %edx--- qword %rdx:%rax r/m64 %rax %rdx------ We do a special case for the byte division because the current--- codegen doesn't deal well with accessing %ah register (also,--- accessing %ah in 64-bit mode is complicated because it cannot be an--- operand of many instructions). So we just widen operands to 16 bits--- and get the results from %al, %dl. This is not optimal, but a few--- register moves are probably not a huge deal when doing division.--genCCall32' :: ForeignTarget -- function to call- -> [CmmFormal] -- where to put the result- -> [CmmActual] -- arguments (of mixed type)- -> NatM InstrBlock-genCCall32' target dest_regs args = do- config <- getConfig- let platform = ncgPlatform config- prom_args = map (maybePromoteCArg platform W32) args-- -- If the size is smaller than the word, we widen things (see maybePromoteCArg)- arg_size_bytes :: CmmType -> Int- arg_size_bytes ty = max (widthInBytes (typeWidth ty)) (widthInBytes (wordWidth platform))-- roundTo a x | x `mod` a == 0 = x- | otherwise = x + a - (x `mod` a)-- push_arg :: CmmActual {-current argument-}- -> NatM InstrBlock -- code-- push_arg arg -- we don't need the hints on x86- | isWord64 arg_ty = do- ChildCode64 code r_lo <- iselExpr64 arg- delta <- getDeltaNat- setDeltaNat (delta - 8)- let r_hi = getHiVRegFromLo r_lo- return ( code `appOL`- toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4),- PUSH II32 (OpReg r_lo), DELTA (delta - 8),- DELTA (delta-8)]- )-- | isFloatType arg_ty = do- (reg, code) <- getSomeReg arg- delta <- getDeltaNat- setDeltaNat (delta-size)- return (code `appOL`- toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp),- DELTA (delta-size),- let addr = AddrBaseIndex (EABaseReg esp)- EAIndexNone- (ImmInt 0)- format = floatFormat (typeWidth arg_ty)- in-- -- assume SSE2- MOV format (OpReg reg) (OpAddr addr)-- ]- )-- | otherwise = do- -- Arguments can be smaller than 32-bit, but we still use @PUSH- -- II32@ - the usual calling conventions expect integers to be- -- 4-byte aligned.- massert ((typeWidth arg_ty) <= W32)- (operand, code) <- getOperand arg- delta <- getDeltaNat- setDeltaNat (delta-size)- return (code `snocOL`- PUSH II32 operand `snocOL`- DELTA (delta-size))-- where- arg_ty = cmmExprType platform arg- size = arg_size_bytes arg_ty -- Byte size-- let- -- Align stack to 16n for calls, assuming a starting stack- -- alignment of 16n - word_size on procedure entry. Which we- -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86]- sizes = map (arg_size_bytes . cmmExprType platform) (reverse args)- raw_arg_size = sum sizes + platformWordSizeInBytes platform- arg_pad_size = (roundTo 16 $ raw_arg_size) - raw_arg_size- tot_arg_size = raw_arg_size + arg_pad_size - platformWordSizeInBytes platform--- delta0 <- getDeltaNat- setDeltaNat (delta0 - arg_pad_size)-- push_codes <- mapM push_arg (reverse prom_args)- delta <- getDeltaNat- massert (delta == delta0 - tot_arg_size)-- -- deal with static vs dynamic call targets- (callinsns,cconv) <-- case target of- ForeignTarget (CmmLit (CmmLabel lbl)) conv- -> -- ToDo: stdcall arg sizes- return (unitOL (CALL (Left fn_imm) []), conv)- where fn_imm = ImmCLbl lbl- ForeignTarget expr conv- -> do { (dyn_r, dyn_c) <- getSomeReg expr- ; massert (isWord32 (cmmExprType platform expr))- ; return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }- PrimTarget _- -> panic $ "genCCall: Can't handle PrimTarget call type here, error "- ++ "probably because too many return values."-- let push_code- | arg_pad_size /= 0- = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp),- DELTA (delta0 - arg_pad_size)]- `appOL` concatOL push_codes- | otherwise- = concatOL push_codes-- -- Deallocate parameters after call for ccall;- -- but not for stdcall (callee does it)- --- -- We have to pop any stack padding we added- -- even if we are doing stdcall, though (#5052)- pop_size- | ForeignConvention StdCallConv _ _ _ <- cconv = arg_pad_size- | otherwise = tot_arg_size-- call = callinsns `appOL`- toOL (- (if pop_size==0 then [] else- [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)])- ++- [DELTA delta0]- )- setDeltaNat delta0-- let- -- assign the results, if necessary- assign_code [] = nilOL- assign_code [dest]- | isFloatType ty =- -- we assume SSE2- let tmp_amode = AddrBaseIndex (EABaseReg esp)- EAIndexNone- (ImmInt 0)- fmt = floatFormat w- in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp),- DELTA (delta0 - b),- X87Store fmt tmp_amode,- -- X87Store only supported for the CDECL ABI- -- NB: This code will need to be- -- revisited once GHC does more work around- -- SIGFPE f- MOV fmt (OpAddr tmp_amode) (OpReg r_dest),- ADD II32 (OpImm (ImmInt b)) (OpReg esp),- DELTA delta0]- | isWord64 ty = toOL [MOV II32 (OpReg eax) (OpReg r_dest),- MOV II32 (OpReg edx) (OpReg r_dest_hi)]- | otherwise = unitOL (MOV (intFormat w)- (OpReg eax)- (OpReg r_dest))- where- ty = localRegType dest- w = typeWidth ty- b = widthInBytes w- r_dest_hi = getHiVRegFromLo r_dest- r_dest = getRegisterReg platform (CmmLocal dest)- assign_code many = pprPanic "genCCall.assign_code - too many return values:" (ppr many)-- return (push_code `appOL`- call `appOL`- assign_code dest_regs)--genCCall64' :: ForeignTarget -- function to call- -> [CmmFormal] -- where to put the result- -> [CmmActual] -- arguments (of mixed type)- -> NatM InstrBlock-genCCall64' target dest_regs args = do- platform <- getPlatform- -- load up the register arguments- let prom_args = map (maybePromoteCArg platform W32) args-- let load_args :: [CmmExpr]- -> [Reg] -- int regs avail for args- -> [Reg] -- FP regs avail for args- -> InstrBlock -- code computing args- -> InstrBlock -- code assigning args to ABI regs- -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)- -- no more regs to use- load_args args [] [] code acode =- return (args, [], [], code, acode)-- -- no more args to push- load_args [] aregs fregs code acode =- return ([], aregs, fregs, code, acode)-- load_args (arg : rest) aregs fregs code acode- | isFloatType arg_rep = case fregs of- [] -> push_this_arg- (r:rs) -> do- (code',acode') <- reg_this_arg r- load_args rest aregs rs code' acode'- | otherwise = case aregs of- [] -> push_this_arg- (r:rs) -> do- (code',acode') <- reg_this_arg r- load_args rest rs fregs code' acode'- where-- -- put arg into the list of stack pushed args- push_this_arg = do- (args',ars,frs,code',acode')- <- load_args rest aregs fregs code acode- return (arg:args', ars, frs, code', acode')-- -- pass the arg into the given register- reg_this_arg r- -- "operand" args can be directly assigned into r- | isOperand False arg = do- arg_code <- getAnyReg arg- return (code, (acode `appOL` arg_code r))- -- The last non-operand arg can be directly assigned after its- -- computation without going into a temporary register- | all (isOperand False) rest = do- arg_code <- getAnyReg arg- return (code `appOL` arg_code r,acode)-- -- other args need to be computed beforehand to avoid clobbering- -- previously assigned registers used to pass parameters (see- -- #11792, #12614). They are assigned into temporary registers- -- and get assigned to proper call ABI registers after they all- -- have been computed.- | otherwise = do- arg_code <- getAnyReg arg- tmp <- getNewRegNat arg_fmt- let- code' = code `appOL` arg_code tmp- acode' = acode `snocOL` reg2reg arg_fmt tmp r- return (code',acode')-- arg_rep = cmmExprType platform arg- arg_fmt = cmmTypeFormat arg_rep-- load_args_win :: [CmmExpr]- -> [Reg] -- used int regs- -> [Reg] -- used FP regs- -> [(Reg, Reg)] -- (int, FP) regs avail for args- -> InstrBlock- -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)- load_args_win args usedInt usedFP [] code- = return (args, usedInt, usedFP, code, nilOL)- -- no more regs to use- load_args_win [] usedInt usedFP _ code- = return ([], usedInt, usedFP, code, nilOL)- -- no more args to push- load_args_win (arg : rest) usedInt usedFP- ((ireg, freg) : regs) code- | isFloatType arg_rep = do- arg_code <- getAnyReg arg- load_args_win rest (ireg : usedInt) (freg : usedFP) regs- (code `appOL`- arg_code freg `snocOL`- -- If we are calling a varargs function- -- then we need to define ireg as well- -- as freg- MOV II64 (OpReg freg) (OpReg ireg))- | otherwise = do- arg_code <- getAnyReg arg- load_args_win rest (ireg : usedInt) usedFP regs- (code `appOL` arg_code ireg)- where- arg_rep = cmmExprType platform arg-- arg_size = 8 -- always, at the mo-- push_args [] code = return code- push_args (arg:rest) code- | isFloatType arg_rep = do- (arg_reg, arg_code) <- getSomeReg arg- delta <- getDeltaNat- setDeltaNat (delta-arg_size)- let code' = code `appOL` arg_code `appOL` toOL [- SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_size)) (OpReg rsp),- DELTA (delta-arg_size),- MOV (floatFormat width) (OpReg arg_reg) (OpAddr (spRel platform 0))]- push_args rest code'-- | otherwise = do- -- Arguments can be smaller than 64-bit, but we still use @PUSH- -- II64@ - the usual calling conventions expect integers to be- -- 8-byte aligned.- massert (width <= W64)- (arg_op, arg_code) <- getOperand arg- delta <- getDeltaNat- setDeltaNat (delta-arg_size)- let code' = code `appOL` arg_code `appOL` toOL [- PUSH II64 arg_op,- DELTA (delta-arg_size)]- push_args rest code'- where- arg_rep = cmmExprType platform arg- width = typeWidth arg_rep-- leaveStackSpace n = do- delta <- getDeltaNat- setDeltaNat (delta - n * arg_size)- return $ toOL [- SUB II64 (OpImm (ImmInt (n * platformWordSizeInBytes platform))) (OpReg rsp),- DELTA (delta - n * arg_size)]-- (stack_args, int_regs_used, fp_regs_used, load_args_code, assign_args_code)- <-- if platformOS platform == OSMinGW32- then load_args_win prom_args [] [] (allArgRegs platform) nilOL- else do- (stack_args, aregs, fregs, load_args_code, assign_args_code)- <- load_args prom_args (allIntArgRegs platform)- (allFPArgRegs platform)- nilOL nilOL- let used_regs rs as = reverse (drop (length rs) (reverse as))- fregs_used = used_regs fregs (allFPArgRegs platform)- aregs_used = used_regs aregs (allIntArgRegs platform)- return (stack_args, aregs_used, fregs_used, load_args_code- , assign_args_code)-- let- arg_regs_used = int_regs_used ++ fp_regs_used- arg_regs = [eax] ++ arg_regs_used- -- for annotating the call instruction with- sse_regs = length fp_regs_used- arg_stack_slots = if platformOS platform == OSMinGW32- then length stack_args + length (allArgRegs platform)- else length stack_args- tot_arg_size = arg_size * arg_stack_slots--- -- Align stack to 16n for calls, assuming a starting stack- -- alignment of 16n - word_size on procedure entry. Which we- -- maintain. See Note [rts/StgCRun.c : Stack Alignment on X86]- let word_size = platformWordSizeInBytes platform- (real_size, adjust_rsp) <-- if (tot_arg_size + word_size) `rem` 16 == 0- then return (tot_arg_size, nilOL)- else do -- we need to adjust...- delta <- getDeltaNat- setDeltaNat (delta - word_size)- return (tot_arg_size + word_size, toOL [- SUB II64 (OpImm (ImmInt word_size)) (OpReg rsp),- DELTA (delta - word_size) ])-- -- push the stack args, right to left- push_code <- push_args (reverse stack_args) nilOL- -- On Win64, we also have to leave stack space for the arguments- -- that we are passing in registers- lss_code <- if platformOS platform == OSMinGW32- then leaveStackSpace (length (allArgRegs platform))- else return nilOL- delta <- getDeltaNat-- -- deal with static vs dynamic call targets- (callinsns,_cconv) <-- case target of- ForeignTarget (CmmLit (CmmLabel lbl)) conv- -> -- ToDo: stdcall arg sizes- return (unitOL (CALL (Left fn_imm) arg_regs), conv)- where fn_imm = ImmCLbl lbl- ForeignTarget expr conv- -> do (dyn_r, dyn_c) <- getSomeReg expr- return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv)- PrimTarget _- -> panic $ "genCCall: Can't handle PrimTarget call type here, error "- ++ "probably because too many return values."-- let- -- The x86_64 ABI requires us to set %al to the number of SSE2- -- registers that contain arguments, if the called routine- -- is a varargs function. We don't know whether it's a- -- varargs function or not, so we have to assume it is.- --- -- It's not safe to omit this assignment, even if the number- -- of SSE2 regs in use is zero. If %al is larger than 8- -- on entry to a varargs function, seg faults ensue.- assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax))-- let call = callinsns `appOL`- toOL (- -- Deallocate parameters after call for ccall;- -- stdcall has callee do it, but is not supported on- -- x86_64 target (see #3336)- (if real_size==0 then [] else- [ADD (intFormat (platformWordWidth platform)) (OpImm (ImmInt real_size)) (OpReg esp)])- ++- [DELTA (delta + real_size)]- )- setDeltaNat (delta + real_size)-- let- -- assign the results, if necessary- assign_code [] = nilOL- assign_code [dest] =- case typeWidth rep of- W32 | isFloatType rep -> unitOL (MOV (floatFormat W32)- (OpReg xmm0)- (OpReg r_dest))- W64 | isFloatType rep -> unitOL (MOV (floatFormat W64)- (OpReg xmm0)- (OpReg r_dest))- _ -> unitOL (MOV (cmmTypeFormat rep) (OpReg rax) (OpReg r_dest))- where- rep = localRegType dest- r_dest = getRegisterReg platform (CmmLocal dest)- assign_code _many = panic "genCCall.assign_code many"-- return (adjust_rsp `appOL`- push_code `appOL`- load_args_code `appOL`- assign_args_code `appOL`- lss_code `appOL`- assign_eax sse_regs `appOL`- call `appOL`- assign_code dest_regs)---maybePromoteCArg :: Platform -> Width -> CmmExpr -> CmmExpr-maybePromoteCArg platform wto arg- | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg]- | otherwise = arg- where- wfrom = cmmExprWidth platform arg--outOfLineCmmOp :: BlockId -> CallishMachOp -> Maybe CmmFormal -> [CmmActual]- -> NatM InstrBlock-outOfLineCmmOp bid mop res args- = do- config <- getConfig- targetExpr <- cmmMakeDynamicReference config CallReference lbl- let target = ForeignTarget targetExpr- (ForeignConvention CCallConv [] [] CmmMayReturn)-- -- We know foreign calls results in no new basic blocks, so we can ignore- -- the returned block id.- (instrs, _) <- stmtToInstrs bid (CmmUnsafeForeignCall target (catMaybes [res]) args)- return instrs- where- -- Assume we can call these functions directly, and that they're not in a dynamic library.- -- TODO: Why is this ok? Under linux this code will be in libm.so- -- Is it because they're really implemented as a primitive instruction by the assembler?? -- BL 2009/12/31- lbl = mkForeignLabel fn Nothing ForeignLabelInThisPackage IsFunction-- fn = case mop of- MO_F32_Sqrt -> fsLit "sqrtf"- MO_F32_Fabs -> fsLit "fabsf"- MO_F32_Sin -> fsLit "sinf"- MO_F32_Cos -> fsLit "cosf"- MO_F32_Tan -> fsLit "tanf"- MO_F32_Exp -> fsLit "expf"- MO_F32_ExpM1 -> fsLit "expm1f"- MO_F32_Log -> fsLit "logf"- MO_F32_Log1P -> fsLit "log1pf"-- MO_F32_Asin -> fsLit "asinf"- MO_F32_Acos -> fsLit "acosf"- MO_F32_Atan -> fsLit "atanf"-- MO_F32_Sinh -> fsLit "sinhf"- MO_F32_Cosh -> fsLit "coshf"- MO_F32_Tanh -> fsLit "tanhf"- MO_F32_Pwr -> fsLit "powf"-- MO_F32_Asinh -> fsLit "asinhf"- MO_F32_Acosh -> fsLit "acoshf"- MO_F32_Atanh -> fsLit "atanhf"-- MO_F64_Sqrt -> fsLit "sqrt"- MO_F64_Fabs -> fsLit "fabs"- MO_F64_Sin -> fsLit "sin"- MO_F64_Cos -> fsLit "cos"- MO_F64_Tan -> fsLit "tan"- MO_F64_Exp -> fsLit "exp"- MO_F64_ExpM1 -> fsLit "expm1"- MO_F64_Log -> fsLit "log"- MO_F64_Log1P -> fsLit "log1p"-- MO_F64_Asin -> fsLit "asin"- MO_F64_Acos -> fsLit "acos"- MO_F64_Atan -> fsLit "atan"-- MO_F64_Sinh -> fsLit "sinh"- MO_F64_Cosh -> fsLit "cosh"- MO_F64_Tanh -> fsLit "tanh"- MO_F64_Pwr -> fsLit "pow"-- MO_F64_Asinh -> fsLit "asinh"- MO_F64_Acosh -> fsLit "acosh"- MO_F64_Atanh -> fsLit "atanh"-- MO_I64_ToI -> fsLit "hs_int64ToInt"- MO_I64_FromI -> fsLit "hs_intToInt64"- MO_W64_ToW -> fsLit "hs_word64ToWord"- MO_W64_FromW -> fsLit "hs_wordToWord64"- MO_x64_Neg -> fsLit "hs_neg64"- MO_x64_Add -> fsLit "hs_add64"- MO_x64_Sub -> fsLit "hs_sub64"- MO_x64_Mul -> fsLit "hs_mul64"- MO_I64_Quot -> fsLit "hs_quotInt64"- MO_I64_Rem -> fsLit "hs_remInt64"- MO_W64_Quot -> fsLit "hs_quotWord64"- MO_W64_Rem -> fsLit "hs_remWord64"- MO_x64_And -> fsLit "hs_and64"- MO_x64_Or -> fsLit "hs_or64"- MO_x64_Xor -> fsLit "hs_xor64"- MO_x64_Not -> fsLit "hs_not64"- MO_x64_Shl -> fsLit "hs_uncheckedShiftL64"- MO_I64_Shr -> fsLit "hs_uncheckedIShiftRA64"- MO_W64_Shr -> fsLit "hs_uncheckedShiftRL64"- MO_x64_Eq -> fsLit "hs_eq64"- MO_x64_Ne -> fsLit "hs_ne64"- MO_I64_Ge -> fsLit "hs_geInt64"- MO_I64_Gt -> fsLit "hs_gtInt64"- MO_I64_Le -> fsLit "hs_leInt64"- MO_I64_Lt -> fsLit "hs_ltInt64"- MO_W64_Ge -> fsLit "hs_geWord64"- MO_W64_Gt -> fsLit "hs_gtWord64"- MO_W64_Le -> fsLit "hs_leWord64"- MO_W64_Lt -> fsLit "hs_ltWord64"-- MO_Memcpy _ -> fsLit "memcpy"- MO_Memset _ -> fsLit "memset"- MO_Memmove _ -> fsLit "memmove"- MO_Memcmp _ -> fsLit "memcmp"-- MO_SuspendThread -> fsLit "suspendThread"- MO_ResumeThread -> fsLit "resumeThread"-- MO_PopCnt _ -> fsLit "popcnt"- MO_BSwap _ -> fsLit "bswap"- {- Here the C implementation is used as there is no x86- instruction to reverse a word's bit order.- -}- MO_BRev w -> bRevLabel w- MO_Clz w -> clzLabel w- MO_Ctz _ -> unsupported-- MO_Pdep w -> pdepLabel w- MO_Pext w -> pextLabel w-- MO_AtomicRMW _ _ -> unsupported- MO_AtomicRead _ -> unsupported- MO_AtomicWrite _ -> unsupported- MO_Cmpxchg w -> cmpxchgLabel w -- for W64 on 32-bit- -- TODO: implement- -- cmpxchg8b instr- MO_Xchg _ -> should_be_inline-- MO_UF_Conv _ -> unsupported-- MO_S_Mul2 {} -> unsupported- MO_S_QuotRem {} -> unsupported- MO_U_QuotRem {} -> unsupported- MO_U_QuotRem2 {} -> unsupported- MO_Add2 {} -> unsupported- MO_AddIntC {} -> unsupported- MO_SubIntC {} -> unsupported- MO_AddWordC {} -> unsupported- MO_SubWordC {} -> unsupported- MO_U_Mul2 {} -> unsupported- MO_ReadBarrier -> unsupported- MO_WriteBarrier -> unsupported- MO_Touch -> unsupported- (MO_Prefetch_Data _ ) -> unsupported- unsupported = panic ("outOfLineCmmOp: " ++ show mop- ++ " not supported here")- -- If we generate a call for the given primop- -- something went wrong.- should_be_inline = panic ("outOfLineCmmOp: " ++ show mop- ++ " should be handled inline")----- -------------------------------------------------------------------------------- Generating a table-branch--genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock--genSwitch expr targets = do- config <- getConfig- let platform = ncgPlatform config- -- We widen to a native-width register because we cannot use arbitry sizes- -- in x86 addressing modes.- exprWidened = CmmMachOp- (MO_UU_Conv (cmmExprWidth platform expr)- (platformWordWidth platform))- [expr]- indexExpr = cmmOffset platform exprWidened offset- if ncgPIC config- then do- (reg,e_code) <- getNonClobberedReg indexExpr- -- getNonClobberedReg because it needs to survive across t_code- lbl <- getNewLabelNat- let is32bit = target32Bit platform- os = platformOS platform- -- Might want to use .rodata.<function we're in> instead, but as- -- long as it's something unique it'll work out since the- -- references to the jump table are in the appropriate section.- rosection = case os of- -- on Mac OS X/x86_64, put the jump table in the text section to- -- work around a limitation of the linker.- -- ld64 is unable to handle the relocations for- -- .quad L1 - L0- -- if L0 is not preceded by a non-anonymous label in its section.- OSDarwin | not is32bit -> Section Text lbl- _ -> Section ReadOnlyData lbl- dynRef <- cmmMakeDynamicReference config DataReference lbl- (tableReg,t_code) <- getSomeReg $ dynRef- let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)- (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))-- offsetReg <- getNewRegNat (intFormat (platformWordWidth platform))- return $ if is32bit || os == OSDarwin- then e_code `appOL` t_code `appOL` toOL [- ADD (intFormat (platformWordWidth platform)) op (OpReg tableReg),- JMP_TBL (OpReg tableReg) ids rosection lbl- ]- else -- HACK: On x86_64 binutils<2.17 is only able to generate- -- PC32 relocations, hence we only get 32-bit offsets in- -- the jump table. As these offsets are always negative- -- we need to properly sign extend them to 64-bit. This- -- hack should be removed in conjunction with the hack in- -- PprMach.hs/pprDataItem once binutils 2.17 is standard.- e_code `appOL` t_code `appOL` toOL [- MOVSxL II32 op (OpReg offsetReg),- ADD (intFormat (platformWordWidth platform))- (OpReg offsetReg)- (OpReg tableReg),- JMP_TBL (OpReg tableReg) ids rosection lbl- ]- else do- (reg,e_code) <- getSomeReg indexExpr- lbl <- getNewLabelNat- let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl lbl))- code = e_code `appOL` toOL [- JMP_TBL op ids (Section ReadOnlyData lbl) lbl- ]- return code- where- (offset, blockIds) = switchTargetsToTable targets- ids = map (fmap DestBlockId) blockIds--generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr)-generateJumpTableForInstr config (JMP_TBL _ ids section lbl)- = let getBlockId (DestBlockId id) = id- getBlockId _ = panic "Non-Label target in Jump Table"- blockIds = map (fmap getBlockId) ids- in Just (createJumpTable config blockIds section lbl)-generateJumpTableForInstr _ _ = Nothing--createJumpTable :: NCGConfig -> [Maybe BlockId] -> Section -> CLabel- -> GenCmmDecl (Alignment, RawCmmStatics) h g-createJumpTable config ids section lbl- = let jumpTable- | ncgPIC config =- let ww = ncgWordWidth config- jumpTableEntryRel Nothing- = CmmStaticLit (CmmInt 0 ww)- jumpTableEntryRel (Just blockid)- = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 ww)- where blockLabel = blockLbl blockid- in map jumpTableEntryRel ids- | otherwise = map (jumpTableEntry config) ids- in CmmData section (mkAlignment 1, CmmStaticsRaw lbl jumpTable)--extractUnwindPoints :: [Instr] -> [UnwindPoint]-extractUnwindPoints instrs =- [ UnwindPoint lbl unwinds | UNWIND lbl unwinds <- instrs]---- -------------------------------------------------------------------------------- 'condIntReg' and 'condFltReg': condition codes into registers---- Turn those condition codes into integers now (when they appear on--- the right hand side of an assignment).------ (If applicable) Do not fill the delay slots here; you will confuse the--- register allocator.--condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register--condIntReg cond x y = do- CondCode _ cond cond_code <- condIntCode cond x y- tmp <- getNewRegNat II8- let- code dst = cond_code `appOL` toOL [- SETCC cond (OpReg tmp),- MOVZxL II8 (OpReg tmp) (OpReg dst)- ]- return (Any II32 code)------------------------------------------------------------------ Note [SSE Parity Checks] ------------------------------------------------------------------- We have to worry about unordered operands (eg. comparisons--- against NaN). If the operands are unordered, the comparison--- sets the parity flag, carry flag and zero flag.--- All comparisons are supposed to return false for unordered--- operands except for !=, which returns true.------ Optimisation: we don't have to test the parity flag if we--- know the test has already excluded the unordered case: eg >--- and >= test for a zero carry flag, which can only occur for--- ordered operands.------ By reversing comparisons we can avoid testing the parity--- for < and <= as well. If any of the arguments is an NaN we--- return false either way. If both arguments are valid then--- x <= y <-> y >= x holds. So it's safe to swap these.------ We invert the condition inside getRegister'and getCondCode--- which should cover all invertable cases.--- All other functions translating FP comparisons to assembly--- use these to two generate the comparison code.------ As an example consider a simple check:------ func :: Float -> Float -> Int--- func x y = if x < y then 1 else 0------ Which in Cmm gives the floating point comparison.------ if (%MO_F_Lt_W32(F1, F2)) goto c2gg; else goto c2gf;------ We used to compile this to an assembly code block like this:--- _c2gh:--- ucomiss %xmm2,%xmm1--- jp _c2gf--- jb _c2gg--- jmp _c2gf------ Where we have to introduce an explicit--- check for unordered results (using jmp parity):------ We can avoid this by exchanging the arguments and inverting the direction--- of the comparison. This results in the sequence of:------ ucomiss %xmm1,%xmm2--- ja _c2g2--- jmp _c2g1------ Removing the jump reduces the pressure on the branch predidiction system--- and plays better with the uOP cache.--condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register-condFltReg is32Bit cond x y = condFltReg_sse2- where--- condFltReg_sse2 = do- CondCode _ cond cond_code <- condFltCode cond x y- tmp1 <- getNewRegNat (archWordFormat is32Bit)- tmp2 <- getNewRegNat (archWordFormat is32Bit)- let -- See Note [SSE Parity Checks]- code dst =- cond_code `appOL`- (case cond of- NE -> or_unordered dst- GU -> plain_test dst- GEU -> plain_test dst- -- Use ASSERT so we don't break releases if these creep in.- LTT -> assertPpr False (ppr "Should have been turned into >") $- and_ordered dst- LE -> assertPpr False (ppr "Should have been turned into >=") $- and_ordered dst- _ -> and_ordered dst)-- plain_test dst = toOL [- SETCC cond (OpReg tmp1),- MOVZxL II8 (OpReg tmp1) (OpReg dst)- ]- or_unordered dst = toOL [- SETCC cond (OpReg tmp1),- SETCC PARITY (OpReg tmp2),- OR II8 (OpReg tmp1) (OpReg tmp2),- MOVZxL II8 (OpReg tmp2) (OpReg dst)- ]- and_ordered dst = toOL [- SETCC cond (OpReg tmp1),- SETCC NOTPARITY (OpReg tmp2),- AND II8 (OpReg tmp1) (OpReg tmp2),- MOVZxL II8 (OpReg tmp2) (OpReg dst)- ]- return (Any II32 code)----- -------------------------------------------------------------------------------- 'trivial*Code': deal with trivial instructions---- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',--- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.--- Only look for constants on the right hand side, because that's--- where the generic optimizer will have put them.---- Similarly, for unary instructions, we don't have to worry about--- matching an StInt as the argument, because genericOpt will already--- have handled the constant-folding.---{--The Rules of the Game are:--* You cannot assume anything about the destination register dst;- it may be anything, including a fixed reg.--* You may compute an operand into a fixed reg, but you may not- subsequently change the contents of that fixed reg. If you- want to do so, first copy the value either to a temporary- or into dst. You are free to modify dst even if it happens- to be a fixed reg -- that's not your problem.--* You cannot assume that a fixed reg will stay live over an- arbitrary computation. The same applies to the dst reg.--* Temporary regs obtained from getNewRegNat are distinct from- each other and from all other regs, and stay live over- arbitrary computations.------------------------SDM's version of The Rules:--* If getRegister returns Any, that means it can generate correct- code which places the result in any register, period. Even if that- register happens to be read during the computation.-- Corollary #1: this means that if you are generating code for an- operation with two arbitrary operands, you cannot assign the result- of the first operand into the destination register before computing- the second operand. The second operand might require the old value- of the destination register.-- Corollary #2: A function might be able to generate more efficient- code if it knows the destination register is a new temporary (and- therefore not read by any of the sub-computations).--* If getRegister returns Any, then the code it generates may modify only:- (a) fresh temporaries- (b) the destination register- (c) known registers (eg. %ecx is used by shifts)- In particular, it may *not* modify global registers, unless the global- register happens to be the destination register.--}--trivialCode :: Width -> (Operand -> Operand -> Instr)- -> Maybe (Operand -> Operand -> Instr)- -> CmmExpr -> CmmExpr -> NatM Register-trivialCode width instr m a b- = do is32Bit <- is32BitPlatform- trivialCode' is32Bit width instr m a b--trivialCode' :: Bool -> Width -> (Operand -> Operand -> Instr)- -> Maybe (Operand -> Operand -> Instr)- -> CmmExpr -> CmmExpr -> NatM Register-trivialCode' is32Bit width _ (Just revinstr) (CmmLit lit_a) b- | is32BitLit is32Bit lit_a = do- b_code <- getAnyReg b- let- code dst- = b_code dst `snocOL`- revinstr (OpImm (litToImm lit_a)) (OpReg dst)- return (Any (intFormat width) code)--trivialCode' _ width instr _ a b- = genTrivialCode (intFormat width) instr a b---- This is re-used for floating pt instructions too.-genTrivialCode :: Format -> (Operand -> Operand -> Instr)- -> CmmExpr -> CmmExpr -> NatM Register-genTrivialCode rep instr a b = do- (b_op, b_code) <- getNonClobberedOperand b- a_code <- getAnyReg a- tmp <- getNewRegNat rep- let- -- We want the value of b to stay alive across the computation of a.- -- But, we want to calculate a straight into the destination register,- -- because the instruction only has two operands (dst := dst `op` src).- -- The troublesome case is when the result of b is in the same register- -- as the destination reg. In this case, we have to save b in a- -- new temporary across the computation of a.- code dst- | dst `regClashesWithOp` b_op =- b_code `appOL`- unitOL (MOV rep b_op (OpReg tmp)) `appOL`- a_code dst `snocOL`- instr (OpReg tmp) (OpReg dst)- | otherwise =- b_code `appOL`- a_code dst `snocOL`- instr b_op (OpReg dst)- return (Any rep code)--regClashesWithOp :: Reg -> Operand -> Bool-reg `regClashesWithOp` OpReg reg2 = reg == reg2-reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode)-_ `regClashesWithOp` _ = False---------------trivialUCode :: Format -> (Operand -> Instr)- -> CmmExpr -> NatM Register-trivialUCode rep instr x = do- x_code <- getAnyReg x- let- code dst =- x_code dst `snocOL`- instr (OpReg dst)- return (Any rep code)----------------trivialFCode_sse2 :: Width -> (Format -> Operand -> Operand -> Instr)- -> CmmExpr -> CmmExpr -> NatM Register-trivialFCode_sse2 pk instr x y- = genTrivialCode format (instr format) x y- where format = floatFormat pk---trivialUFCode :: Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register-trivialUFCode format instr x = do- (x_reg, x_code) <- getSomeReg x- let- code dst =- x_code `snocOL`- instr x_reg dst- return (Any format code)------------------------------------------------------------------------------------coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register-coerceInt2FP from to x = coerce_sse2- where-- coerce_sse2 = do- (x_op, x_code) <- getOperand x -- ToDo: could be a safe operand- let- opc = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD- n -> panic $ "coerceInt2FP.sse: unhandled width ("- ++ show n ++ ")"- code dst = x_code `snocOL` opc (intFormat from) x_op dst- return (Any (floatFormat to) code)- -- works even if the destination rep is <II32-----------------------------------------------------------------------------------coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register-coerceFP2Int from to x = coerceFP2Int_sse2- where- coerceFP2Int_sse2 = do- (x_op, x_code) <- getOperand x -- ToDo: could be a safe operand- let- opc = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ;- n -> panic $ "coerceFP2Init.sse: unhandled width ("- ++ show n ++ ")"- code dst = x_code `snocOL` opc (intFormat to) x_op dst- return (Any (intFormat to) code)- -- works even if the destination rep is <II32------------------------------------------------------------------------------------coerceFP2FP :: Width -> CmmExpr -> NatM Register-coerceFP2FP to x = do- (x_reg, x_code) <- getSomeReg x- let- opc = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD;- n -> panic $ "coerceFP2FP: unhandled width ("- ++ show n ++ ")"- code dst = x_code `snocOL` opc x_reg dst- return (Any ( floatFormat to) code)------------------------------------------------------------------------------------sse2NegCode :: Width -> CmmExpr -> NatM Register-sse2NegCode w x = do- let fmt = floatFormat w- x_code <- getAnyReg x- -- This is how gcc does it, so it can't be that bad:- let- const = case fmt of- FF32 -> CmmInt 0x80000000 W32- FF64 -> CmmInt 0x8000000000000000 W64- x@II8 -> wrongFmt x- x@II16 -> wrongFmt x- x@II32 -> wrongFmt x- x@II64 -> wrongFmt x-- where- wrongFmt x = panic $ "sse2NegCode: " ++ show x- Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const- tmp <- getNewRegNat fmt- let- code dst = x_code dst `appOL` amode_code `appOL` toOL [- MOV fmt (OpAddr amode) (OpReg tmp),- XOR fmt (OpReg tmp) (OpReg dst)- ]- --- return (Any fmt code)--isVecExpr :: CmmExpr -> Bool-isVecExpr (CmmMachOp (MO_V_Insert {}) _) = True-isVecExpr (CmmMachOp (MO_V_Extract {}) _) = True-isVecExpr (CmmMachOp (MO_V_Add {}) _) = True-isVecExpr (CmmMachOp (MO_V_Sub {}) _) = True-isVecExpr (CmmMachOp (MO_V_Mul {}) _) = True-isVecExpr (CmmMachOp (MO_VS_Quot {}) _) = True-isVecExpr (CmmMachOp (MO_VS_Rem {}) _) = True-isVecExpr (CmmMachOp (MO_VS_Neg {}) _) = True-isVecExpr (CmmMachOp (MO_VF_Insert {}) _) = True-isVecExpr (CmmMachOp (MO_VF_Extract {}) _) = True-isVecExpr (CmmMachOp (MO_VF_Add {}) _) = True-isVecExpr (CmmMachOp (MO_VF_Sub {}) _) = True-isVecExpr (CmmMachOp (MO_VF_Mul {}) _) = True-isVecExpr (CmmMachOp (MO_VF_Quot {}) _) = True-isVecExpr (CmmMachOp (MO_VF_Neg {}) _) = True-isVecExpr (CmmMachOp _ [e]) = isVecExpr e-isVecExpr _ = False--needLlvm :: NatM a-needLlvm =- sorry $ unlines ["The native code generator does not support vector"- ,"instructions. Please use -fllvm."]---- | This works on the invariant that all jumps in the given blocks are required.--- Starting from there we try to make a few more jumps redundant by reordering--- them.--- We depend on the information in the CFG to do so so without a given CFG--- we do nothing.-invertCondBranches :: Maybe CFG -- ^ CFG if present- -> LabelMap a -- ^ Blocks with info tables- -> [NatBasicBlock Instr] -- ^ List of basic blocks- -> [NatBasicBlock Instr]-invertCondBranches Nothing _ bs = bs-invertCondBranches (Just cfg) keep bs =- invert bs- where- invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr]- invert ((BasicBlock lbl1 ins@(_:_:_xs)):b2@(BasicBlock lbl2 _):bs)- | --pprTrace "Block" (ppr lbl1) True,- (jmp1,jmp2) <- last2 ins- , JXX cond1 target1 <- jmp1- , target1 == lbl2- --, pprTrace "CutChance" (ppr b1) True- , JXX ALWAYS target2 <- jmp2- -- We have enough information to check if we can perform the inversion- -- TODO: We could also check for the last asm instruction which sets- -- status flags instead. Which I suspect is worse in terms of compiler- -- performance, but might be applicable to more cases- , Just edgeInfo1 <- getEdgeInfo lbl1 target1 cfg- , Just edgeInfo2 <- getEdgeInfo lbl1 target2 cfg- -- Both jumps come from the same cmm statement- , transitionSource edgeInfo1 == transitionSource edgeInfo2- , CmmSource {trans_cmmNode = cmmCondBranch} <- transitionSource edgeInfo1-- --Int comparisons are invertable- , CmmCondBranch (CmmMachOp op _args) _ _ _ <- cmmCondBranch- , Just _ <- maybeIntComparison op- , Just invCond <- maybeInvertCond cond1-- --Swap the last two jumps, invert the conditional jumps condition.- = let jumps =- case () of- -- We are free the eliminate the jmp. So we do so.- _ | not (mapMember target1 keep)- -> [JXX invCond target2]- -- If the conditional target is unlikely we put the other- -- target at the front.- | edgeWeight edgeInfo2 > edgeWeight edgeInfo1- -> [JXX invCond target2, JXX ALWAYS target1]- -- Keep things as-is otherwise- | otherwise- -> [jmp1, jmp2]- in --pprTrace "Cutable" (ppr [jmp1,jmp2] <+> text "=>" <+> ppr jumps) $- (BasicBlock lbl1- (dropTail 2 ins ++ jumps))- : invert (b2:bs)- invert (b:bs) = b : invert bs- invert [] = []+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE TupleSections #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-----------------------------------------------------------------------------+--+-- Generating machine code (instruction selection)+--+-- (c) The University of Glasgow 1996-2004+--+-----------------------------------------------------------------------------++-- This is a big module, but, if you pay attention to+-- (a) the sectioning, and (b) the type signatures, the+-- structure should not be too overwhelming.++module GHC.CmmToAsm.X86.CodeGen (+ cmmTopCodeGen,+ generateJumpTableForInstr,+ extractUnwindPoints,+ invertCondBranches,+ InstrBlock+)++where++-- NCG stuff:+import GHC.Prelude++import GHC.CmmToAsm.X86.Instr+import GHC.CmmToAsm.X86.Cond+import GHC.CmmToAsm.X86.Regs+import GHC.CmmToAsm.X86.Ppr+import GHC.CmmToAsm.X86.RegInfo++import GHC.Platform.Regs+import GHC.CmmToAsm.CPrim+import GHC.CmmToAsm.Types+import GHC.Cmm.DebugBlock+ ( DebugBlock(..), UnwindPoint(..), UnwindTable+ , UnwindExpr(UwReg), toUnwindExpr+ )+import GHC.CmmToAsm.PIC+import GHC.CmmToAsm.Monad+ ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat+ , getDeltaNat, getBlockIdNat, getPicBaseNat+ , Reg64(..), RegCode64(..), getNewReg64, localReg64+ , getPicBaseMaybeNat, getDebugBlock, getFileId+ , addImmediateSuccessorNat, updateCfgNat, getConfig, getPlatform+ , getCfgWeights+ )+import GHC.CmmToAsm.CFG+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Config+import GHC.Platform.Reg+import GHC.Platform++-- Our intermediate code:+import GHC.Types.Basic+import GHC.Cmm.BlockId+import GHC.Unit.Types ( primUnitId )+import GHC.Cmm.Utils+import GHC.Cmm.Switch+import GHC.Cmm+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.CLabel+import GHC.Types.Tickish ( GenTickish(..) )+import GHC.Types.SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )++-- The rest:+import GHC.Types.ForeignCall ( CCallConv(..) )+import GHC.Data.OrdList+import GHC.Utils.Outputable+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Data.FastString+import GHC.Utils.Misc+import GHC.Types.Unique.Supply ( getUniqueM )++import Control.Monad+import Data.Foldable (fold)+import Data.Int+import Data.Maybe+import Data.Word++import qualified Data.Map as M++is32BitPlatform :: NatM Bool+is32BitPlatform = do+ platform <- getPlatform+ return $ target32Bit platform++expect32BitPlatform :: SDoc -> NatM ()+expect32BitPlatform doc = do+ is32Bit <- is32BitPlatform+ when (not is32Bit) $+ pprPanic "Expecting 32-bit platform" doc++sse2Enabled :: NatM Bool+sse2Enabled = do+ config <- getConfig+ return (ncgSseVersion config >= Just SSE2)++sse4_2Enabled :: NatM Bool+sse4_2Enabled = do+ config <- getConfig+ return (ncgSseVersion config >= Just SSE42)++cmmTopCodeGen+ :: RawCmmDecl+ -> NatM [NatCmmDecl (Alignment, RawCmmStatics) Instr]++cmmTopCodeGen (CmmProc info lab live graph) = do+ let blocks = toBlockListEntryFirst graph+ (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks+ picBaseMb <- getPicBaseMaybeNat+ platform <- getPlatform+ let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)+ tops = proc : concat statics+ os = platformOS platform++ case picBaseMb of+ Just picBase -> initializePicBase_x86 ArchX86 os picBase tops+ Nothing -> return tops++cmmTopCodeGen (CmmData sec dat) =+ return [CmmData sec (mkAlignment 1, dat)] -- no translation, we just use CmmStatic++{- Note [Verifying basic blocks]+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ We want to guarantee a few things about the results+ of instruction selection.++ Namely that each basic blocks consists of:+ * A (potentially empty) sequence of straight line instructions+ followed by+ * A (potentially empty) sequence of jump like instructions.++ We can verify this by going through the instructions and+ making sure that any non-jumpish instruction can't appear+ after a jumpish instruction.++ There are gotchas however:+ * CALLs are strictly speaking control flow but here we care+ not about them. Hence we treat them as regular instructions.++ It's safe for them to appear inside a basic block+ as (ignoring side effects inside the call) they will result in+ straight line code.++ * NEWBLOCK marks the start of a new basic block so can+ be followed by any instructions.+-}++-- Verifying basic blocks is cheap, but not cheap enough to enable it unconditionally.+verifyBasicBlock :: Platform -> [Instr] -> ()+verifyBasicBlock platform instrs+ | debugIsOn = go False instrs+ | otherwise = ()+ where+ go _ [] = ()+ go atEnd (i:instr)+ = case i of+ -- Start a new basic block+ NEWBLOCK {} -> go False instr+ -- Calls are not viable block terminators+ CALL {} | atEnd -> faultyBlockWith i+ | not atEnd -> go atEnd instr+ -- All instructions ok, check if we reached the end and continue.+ _ | not atEnd -> go (isJumpishInstr i) instr+ -- Only jumps allowed at the end of basic blocks.+ | otherwise -> if isJumpishInstr i+ then go True instr+ else faultyBlockWith i+ faultyBlockWith i+ = pprPanic "Non control flow instructions after end of basic block."+ (pprInstr platform i <+> text "in:" $$ vcat (map (pprInstr platform) instrs))++basicBlockCodeGen+ :: CmmBlock+ -> NatM ( [NatBasicBlock Instr]+ , [NatCmmDecl (Alignment, RawCmmStatics) Instr])++basicBlockCodeGen block = do+ let (_, nodes, tail) = blockSplit block+ id = entryLabel block+ stmts = blockToList nodes+ -- Generate location directive+ dbg <- getDebugBlock (entryLabel block)+ loc_instrs <- case dblSourceTick =<< dbg of+ Just (SourceNote span name)+ -> do fileId <- getFileId (srcSpanFile span)+ let line = srcSpanStartLine span; col = srcSpanStartCol span+ return $ unitOL $ LOCATION fileId line col name+ _ -> return nilOL+ (mid_instrs,mid_bid) <- stmtsToInstrs id stmts+ (!tail_instrs,_) <- stmtToInstrs mid_bid tail+ let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs+ platform <- getPlatform+ return $! verifyBasicBlock platform (fromOL instrs)+ instrs' <- fold <$> traverse addSpUnwindings instrs+ -- code generation may introduce new basic block boundaries, which+ -- are indicated by the NEWBLOCK instruction. We must split up the+ -- instruction stream into basic blocks again. Also, we extract+ -- LDATAs here too.+ let+ (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs'++ mkBlocks (NEWBLOCK id) (instrs,blocks,statics)+ = ([], BasicBlock id instrs : blocks, statics)+ mkBlocks (LDATA sec dat) (instrs,blocks,statics)+ = (instrs, blocks, CmmData sec dat:statics)+ mkBlocks instr (instrs,blocks,statics)+ = (instr:instrs, blocks, statics)+ return (BasicBlock id top : other_blocks, statics)++-- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes+-- in the @sp@ register. See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock"+-- for details.+addSpUnwindings :: Instr -> NatM (OrdList Instr)+addSpUnwindings instr@(DELTA d) = do+ config <- getConfig+ if ncgDwarfUnwindings config+ then do lbl <- mkAsmTempLabel <$> getUniqueM+ let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d)+ return $ toOL [ instr, UNWIND lbl unwind ]+ else return (unitOL instr)+addSpUnwindings instr = return $ unitOL instr++{- Note [Keeping track of the current block]+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When generating instructions for Cmm we sometimes require+the current block for things like retry loops.++We also sometimes change the current block, if a MachOP+results in branching control flow.++Issues arise if we have two statements in the same block,+which both depend on the current block id *and* change the+basic block after them. This happens for atomic primops+in the X86 backend where we want to update the CFG data structure+when introducing new basic blocks.++For example in #17334 we got this Cmm code:++ c3Bf: // global+ (_s3t1::I64) = call MO_AtomicRMW W64 AMO_And(_s3sQ::P64 + 88, 18);+ (_s3t4::I64) = call MO_AtomicRMW W64 AMO_Or(_s3sQ::P64 + 88, 0);+ _s3sT::I64 = _s3sV::I64;+ goto c3B1;++This resulted in two new basic blocks being inserted:++ c3Bf:+ movl $18,%vI_n3Bo+ movq 88(%vI_s3sQ),%rax+ jmp _n3Bp+ n3Bp:+ ...+ cmpxchgq %vI_n3Bq,88(%vI_s3sQ)+ jne _n3Bp+ ...+ jmp _n3Bs+ n3Bs:+ ...+ cmpxchgq %vI_n3Bt,88(%vI_s3sQ)+ jne _n3Bs+ ...+ jmp _c3B1+ ...++Based on the Cmm we called stmtToInstrs we translated both atomic operations under+the assumption they would be placed into their Cmm basic block `c3Bf`.+However for the retry loop we introduce new labels, so this is not the case+for the second statement.+This resulted in a desync between the explicit control flow graph+we construct as a separate data type and the actual control flow graph in the code.++Instead we now return the new basic block if a statement causes a change+in the current block and use the block for all following statements.++For this reason genForeignCall is also split into two parts. One for calls which+*won't* change the basic blocks in which successive instructions will be+placed (since they only evaluate CmmExpr, which can only contain MachOps, which+cannot introduce basic blocks in their lowerings). A different one for calls+which *are* known to change the basic block.++-}++-- See Note [Keeping track of the current block] for why+-- we pass the BlockId.+stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in.+ -> [CmmNode O O] -- ^ Cmm Statement+ -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction+stmtsToInstrs bid stmts =+ go bid stmts nilOL+ where+ go bid [] instrs = return (instrs,bid)+ go bid (s:stmts) instrs = do+ (instrs',bid') <- stmtToInstrs bid s+ -- If the statement introduced a new block, we use that one+ let !newBid = fromMaybe bid bid'+ go newBid stmts (instrs `appOL` instrs')++-- | `bid` refers to the current block and is used to update the CFG+-- if new blocks are inserted in the control flow.+-- See Note [Keeping track of the current block] for more details.+stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in.+ -> CmmNode e x+ -> NatM (InstrBlock, Maybe BlockId)+ -- ^ Instructions, and bid of new block if successive+ -- statements are placed in a different basic block.+stmtToInstrs bid stmt = do+ is32Bit <- is32BitPlatform+ platform <- getPlatform+ case stmt of+ CmmUnsafeForeignCall target result_regs args+ -> genForeignCall target result_regs args bid++ _ -> (,Nothing) <$> case stmt of+ CmmComment s -> return (unitOL (COMMENT $ ftext s))+ CmmTick {} -> return nilOL++ CmmUnwind regs -> do+ let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable+ to_unwind_entry (reg, expr) = M.singleton reg (fmap (toUnwindExpr platform) expr)+ case foldMap to_unwind_entry regs of+ tbl | M.null tbl -> return nilOL+ | otherwise -> do+ lbl <- mkAsmTempLabel <$> getUniqueM+ return $ unitOL $ UNWIND lbl tbl++ CmmAssign reg src+ | isFloatType ty -> assignReg_FltCode format reg src+ | is32Bit && isWord64 ty -> assignReg_I64Code reg src+ | otherwise -> assignReg_IntCode format reg src+ where ty = cmmRegType platform reg+ format = cmmTypeFormat ty++ CmmStore addr src _alignment+ | isFloatType ty -> assignMem_FltCode format addr src+ | is32Bit && isWord64 ty -> assignMem_I64Code addr src+ | otherwise -> assignMem_IntCode format addr src+ where ty = cmmExprType platform src+ format = cmmTypeFormat ty++ CmmBranch id -> return $ genBranch id++ --We try to arrange blocks such that the likely branch is the fallthrough+ --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.+ CmmCondBranch arg true false _ -> genCondBranch bid true false arg+ CmmSwitch arg ids -> genSwitch arg ids+ CmmCall { cml_target = arg+ , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs)+ _ ->+ panic "stmtToInstrs: statement should have been cps'd away"+++jumpRegs :: Platform -> [GlobalReg] -> [Reg]+jumpRegs platform gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]++--------------------------------------------------------------------------------+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.+-- They are really trees of insns to facilitate fast appending, where a+-- left-to-right traversal yields the insns in the correct order.+--+type InstrBlock+ = OrdList Instr+++-- | Condition codes passed up the tree.+--+data CondCode+ = CondCode Bool Cond InstrBlock+++-- | Register's passed up the tree. If the stix code forces the register+-- to live in a pre-decided machine register, it comes out as @Fixed@;+-- otherwise, it comes out as @Any@, and the parent can decide which+-- register to put it in.+--+data Register+ = Fixed Format Reg InstrBlock+ | Any Format (Reg -> InstrBlock)+++swizzleRegisterRep :: Register -> Format -> Register+swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code+swizzleRegisterRep (Any _ codefn) format = Any format codefn++getLocalRegReg :: LocalReg -> Reg+getLocalRegReg (LocalReg u pk)+ = -- by Assuming SSE2, Int,Word,Float,Double all can be register allocated+ RegVirtual (mkVirtualReg u (cmmTypeFormat pk))++-- | Grab the Reg for a CmmReg+getRegisterReg :: Platform -> CmmReg -> Reg++getRegisterReg _ (CmmLocal lreg) = getLocalRegReg lreg++getRegisterReg platform (CmmGlobal mid)+ = case globalRegMaybe platform mid of+ Just reg -> RegReal $ reg+ Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)+ -- By this stage, the only MagicIds remaining should be the+ -- ones which map to a real machine register on this+ -- platform. Hence ...+++-- | Memory addressing modes passed up the tree.+data Amode+ = Amode AddrMode InstrBlock++{-+Now, given a tree (the argument to a CmmLoad) that references memory,+produce a suitable addressing mode.++A Rule of the Game (tm) for Amodes: use of the addr bit must+immediately follow use of the code part, since the code part puts+values in registers which the addr then refers to. So you can't put+anything in between, lest it overwrite some of those registers. If+you need to do some other computation between the code part and use of+the addr bit, first store the effective address from the amode in a+temporary, then do the other computation, and then use the temporary:++ code+ LEA amode, tmp+ ... other computation ...+ ... (tmp) ...+-}+++-- | Check whether an integer will fit in 32 bits.+-- A CmmInt is intended to be truncated to the appropriate+-- number of bits, so here we truncate it to Int64. This is+-- important because e.g. -1 as a CmmInt might be either+-- -1 or 18446744073709551615.+--+is32BitInteger :: Integer -> Bool+is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000+ where i64 = fromIntegral i :: Int64+++-- | Convert a BlockId to some CmmStatic data+jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic+jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config))+jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)+ where blockLabel = blockLbl blockid+++-- -----------------------------------------------------------------------------+-- General things for putting together code sequences++-- Expand CmmRegOff. ToDo: should we do it this way around, or convert+-- CmmExprs into CmmRegOff?+mangleIndexTree :: Platform -> CmmReg -> Int -> CmmExpr+mangleIndexTree platform reg off+ = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]+ where width = typeWidth (cmmRegType platform reg)++-- | The dual to getAnyReg: compute an expression into a register, but+-- we don't mind which one it is.+getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)+getSomeReg expr = do+ r <- getRegister expr+ case r of+ Any rep code -> do+ tmp <- getNewRegNat rep+ return (tmp, code tmp)+ Fixed _ reg code ->+ return (reg, code)+++assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock+assignMem_I64Code addrTree valueTree = do+ Amode addr addr_code <- getAmode addrTree+ RegCode64 vcode rhi rlo <- iselExpr64 valueTree+ let+ -- Little-endian store+ mov_lo = MOV II32 (OpReg rlo) (OpAddr addr)+ mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4)))+ return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)+++assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock+assignReg_I64Code (CmmLocal dst) valueTree = do+ RegCode64 vcode r_src_hi r_src_lo <- iselExpr64 valueTree+ let+ Reg64 r_dst_hi r_dst_lo = localReg64 dst+ mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo)+ mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi)+ return (+ vcode `snocOL` mov_lo `snocOL` mov_hi+ )++assignReg_I64Code _ _+ = panic "assignReg_I64Code(i386): invalid lvalue"+++iselExpr64 :: HasDebugCallStack => CmmExpr -> NatM (RegCode64 InstrBlock)+iselExpr64 (CmmLit (CmmInt i _)) = do+ Reg64 rhi rlo <- getNewReg64+ let+ r = fromIntegral (fromIntegral i :: Word32)+ q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)+ code = toOL [+ MOV II32 (OpImm (ImmInteger r)) (OpReg rlo),+ MOV II32 (OpImm (ImmInteger q)) (OpReg rhi)+ ]+ return (RegCode64 code rhi rlo)++iselExpr64 (CmmLoad addrTree ty _) | isWord64 ty = do+ Amode addr addr_code <- getAmode addrTree+ Reg64 rhi rlo <- getNewReg64+ let+ mov_lo = MOV II32 (OpAddr addr) (OpReg rlo)+ mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi)+ return (+ RegCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) rhi rlo+ )++iselExpr64 (CmmReg (CmmLocal local_reg)) = do+ let Reg64 hi lo = localReg64 local_reg+ return (RegCode64 nilOL hi lo)++-- we handle addition, but rather badly+iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do+ RegCode64 code1 r1hi r1lo <- iselExpr64 e1+ Reg64 rhi rlo <- getNewReg64+ let+ r = fromIntegral (fromIntegral i :: Word32)+ q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)+ code = code1 `appOL`+ toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+ ADD II32 (OpImm (ImmInteger r)) (OpReg rlo),+ MOV II32 (OpReg r1hi) (OpReg rhi),+ ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ]+ return (RegCode64 code rhi rlo)++iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do+ RegCode64 code1 r1hi r1lo <- iselExpr64 e1+ RegCode64 code2 r2hi r2lo <- iselExpr64 e2+ Reg64 rhi rlo <- getNewReg64+ let+ code = code1 `appOL`+ code2 `appOL`+ toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+ ADD II32 (OpReg r2lo) (OpReg rlo),+ MOV II32 (OpReg r1hi) (OpReg rhi),+ ADC II32 (OpReg r2hi) (OpReg rhi) ]+ return (RegCode64 code rhi rlo)++iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do+ RegCode64 code1 r1hi r1lo <- iselExpr64 e1+ RegCode64 code2 r2hi r2lo <- iselExpr64 e2+ Reg64 rhi rlo <- getNewReg64+ let+ code = code1 `appOL`+ code2 `appOL`+ toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+ SUB II32 (OpReg r2lo) (OpReg rlo),+ MOV II32 (OpReg r1hi) (OpReg rhi),+ SBB II32 (OpReg r2hi) (OpReg rhi) ]+ return (RegCode64 code rhi rlo)++iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do+ code <- getAnyReg expr+ Reg64 r_dst_hi r_dst_lo <- getNewReg64+ return $ RegCode64 (code r_dst_lo `snocOL`+ MOV II32 (OpImm (ImmInt 0)) (OpReg r_dst_hi))+ r_dst_hi+ r_dst_lo++iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do+ code <- getAnyReg expr+ Reg64 r_dst_hi r_dst_lo <- getNewReg64+ return $ RegCode64 (code r_dst_lo `snocOL`+ MOV II32 (OpReg r_dst_lo) (OpReg eax) `snocOL`+ CLTD II32 `snocOL`+ MOV II32 (OpReg eax) (OpReg r_dst_lo) `snocOL`+ MOV II32 (OpReg edx) (OpReg r_dst_hi))+ r_dst_hi+ r_dst_lo++iselExpr64 expr+ = do+ platform <- getPlatform+ pprPanic "iselExpr64(i386)" (pdoc platform expr)+++--------------------------------------------------------------------------------+getRegister :: CmmExpr -> NatM Register+getRegister e = do platform <- getPlatform+ is32Bit <- is32BitPlatform+ getRegister' platform is32Bit e++getRegister' :: Platform -> Bool -> CmmExpr -> NatM Register++getRegister' platform is32Bit (CmmReg reg)+ = case reg of+ CmmGlobal PicBaseReg+ | is32Bit ->+ -- on x86_64, we have %rip for PicBaseReg, but it's not+ -- a full-featured register, it can only be used for+ -- rip-relative addressing.+ do reg' <- getPicBaseNat (archWordFormat is32Bit)+ return (Fixed (archWordFormat is32Bit) reg' nilOL)+ _ ->+ do+ let+ fmt = cmmTypeFormat (cmmRegType platform reg)+ format = fmt+ --+ platform <- ncgPlatform <$> getConfig+ return (Fixed format+ (getRegisterReg platform reg)+ nilOL)+++getRegister' platform is32Bit (CmmRegOff r n)+ = getRegister' platform is32Bit $ mangleIndexTree platform r n++getRegister' platform is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e])+ = addAlignmentCheck align <$> getRegister' platform is32Bit e++-- for 32-bit architectures, support some 64 -> 32 bit conversions:+-- TO_W_(x), TO_W_(x >> 32)++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32)+ [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])+ | is32Bit = do+ RegCode64 code rhi _rlo <- iselExpr64 x+ return $ Fixed II32 rhi code++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32)+ [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])+ | is32Bit = do+ RegCode64 code rhi _rlo <- iselExpr64 x+ return $ Fixed II32 rhi code++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x])+ | is32Bit = do+ RegCode64 code _rhi rlo <- iselExpr64 x+ return $ Fixed II32 rlo code++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x])+ | is32Bit = do+ RegCode64 code _rhi rlo <- iselExpr64 x+ return $ Fixed II32 rlo code++getRegister' _ _ (CmmLit lit@(CmmFloat f w)) =+ float_const_sse2 where+ float_const_sse2+ | f == 0.0 = do+ let+ format = floatFormat w+ code dst = unitOL (XOR format (OpReg dst) (OpReg dst))+ -- I don't know why there are xorpd, xorps, and pxor instructions.+ -- They all appear to do the same thing --SDM+ return (Any format code)++ | otherwise = do+ Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit+ loadFloatAmode w addr code++-- catch simple cases of zero- or sign-extended load+getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _ _]) = do+ code <- intLoadCode (MOVZxL II8) addr+ return (Any II32 code)++getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _ _]) = do+ code <- intLoadCode (MOVSxL II8) addr+ return (Any II32 code)++getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _ _]) = do+ code <- intLoadCode (MOVZxL II16) addr+ return (Any II32 code)++getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _ _]) = do+ code <- intLoadCode (MOVSxL II16) addr+ return (Any II32 code)++-- catch simple cases of zero- or sign-extended load+getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _ _])+ | not is32Bit = do+ code <- intLoadCode (MOVZxL II8) addr+ return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _ _])+ | not is32Bit = do+ code <- intLoadCode (MOVSxL II8) addr+ return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _ _])+ | not is32Bit = do+ code <- intLoadCode (MOVZxL II16) addr+ return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _ _])+ | not is32Bit = do+ code <- intLoadCode (MOVSxL II16) addr+ return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _ _])+ | not is32Bit = do+ code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend+ return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _ _])+ | not is32Bit = do+ code <- intLoadCode (MOVSxL II32) addr+ return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),+ CmmLit displacement])+ | not is32Bit =+ return $ Any II64 (\dst -> unitOL $+ LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst))++getRegister' platform is32Bit (CmmMachOp mop [x]) = -- unary MachOps+ case mop of+ MO_F_Neg w -> sse2NegCode w x+++ MO_S_Neg w -> triv_ucode NEGI (intFormat w)+ MO_Not w -> triv_ucode NOT (intFormat w)++ -- Nop conversions+ MO_UU_Conv W32 W8 -> toI8Reg W32 x+ MO_SS_Conv W32 W8 -> toI8Reg W32 x+ MO_XX_Conv W32 W8 -> toI8Reg W32 x+ MO_UU_Conv W16 W8 -> toI8Reg W16 x+ MO_SS_Conv W16 W8 -> toI8Reg W16 x+ MO_XX_Conv W16 W8 -> toI8Reg W16 x+ MO_UU_Conv W32 W16 -> toI16Reg W32 x+ MO_SS_Conv W32 W16 -> toI16Reg W32 x+ MO_XX_Conv W32 W16 -> toI16Reg W32 x++ MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x+ MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x+ MO_XX_Conv W64 W32 | not is32Bit -> conversionNop II64 x+ MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x+ MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x+ MO_XX_Conv W64 W16 | not is32Bit -> toI16Reg W64 x+ MO_UU_Conv W64 W8 | not is32Bit -> toI8Reg W64 x+ MO_SS_Conv W64 W8 | not is32Bit -> toI8Reg W64 x+ MO_XX_Conv W64 W8 | not is32Bit -> toI8Reg W64 x++ MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x+ MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x+ MO_XX_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x++ -- widenings+ MO_UU_Conv W8 W32 -> integerExtend W8 W32 MOVZxL x+ MO_UU_Conv W16 W32 -> integerExtend W16 W32 MOVZxL x+ MO_UU_Conv W8 W16 -> integerExtend W8 W16 MOVZxL x++ MO_SS_Conv W8 W32 -> integerExtend W8 W32 MOVSxL x+ MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x+ MO_SS_Conv W8 W16 -> integerExtend W8 W16 MOVSxL x++ -- We don't care about the upper bits for MO_XX_Conv, so MOV is enough. However, on 32-bit we+ -- have 8-bit registers only for a few registers (as opposed to x86-64 where every register+ -- has 8-bit version). So for 32-bit code, we'll just zero-extend.+ MO_XX_Conv W8 W32+ | is32Bit -> integerExtend W8 W32 MOVZxL x+ | otherwise -> integerExtend W8 W32 MOV x+ MO_XX_Conv W8 W16+ | is32Bit -> integerExtend W8 W16 MOVZxL x+ | otherwise -> integerExtend W8 W16 MOV x+ MO_XX_Conv W16 W32 -> integerExtend W16 W32 MOV x++ MO_UU_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOVZxL x+ MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x+ MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x+ MO_SS_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOVSxL x+ MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x+ MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x+ -- For 32-to-64 bit zero extension, amd64 uses an ordinary movl.+ -- However, we don't want the register allocator to throw it+ -- away as an unnecessary reg-to-reg move, so we keep it in+ -- the form of a movzl and print it as a movl later.+ -- This doesn't apply to MO_XX_Conv since in this case we don't care about+ -- the upper bits. So we can just use MOV.+ MO_XX_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOV x+ MO_XX_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOV x+ MO_XX_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOV x++ MO_FF_Conv W32 W64 -> coerceFP2FP W64 x+++ MO_FF_Conv W64 W32 -> coerceFP2FP W32 x++ MO_FS_Conv from to -> coerceFP2Int from to x+ MO_SF_Conv from to -> coerceInt2FP from to x++ MO_V_Insert {} -> needLlvm+ MO_V_Extract {} -> needLlvm+ MO_V_Add {} -> needLlvm+ MO_V_Sub {} -> needLlvm+ MO_V_Mul {} -> needLlvm+ MO_VS_Quot {} -> needLlvm+ MO_VS_Rem {} -> needLlvm+ MO_VS_Neg {} -> needLlvm+ MO_VU_Quot {} -> needLlvm+ MO_VU_Rem {} -> needLlvm+ MO_VF_Insert {} -> needLlvm+ MO_VF_Extract {} -> needLlvm+ MO_VF_Add {} -> needLlvm+ MO_VF_Sub {} -> needLlvm+ MO_VF_Mul {} -> needLlvm+ MO_VF_Quot {} -> needLlvm+ MO_VF_Neg {} -> needLlvm++ _other -> pprPanic "getRegister" (pprMachOp mop)+ where+ triv_ucode :: (Format -> Operand -> Instr) -> Format -> NatM Register+ triv_ucode instr format = trivialUCode format (instr format) x++ -- signed or unsigned extension.+ integerExtend :: Width -> Width+ -> (Format -> Operand -> Operand -> Instr)+ -> CmmExpr -> NatM Register+ integerExtend from to instr expr = do+ (reg,e_code) <- if from == W8 then getByteReg expr+ else getSomeReg expr+ let+ code dst =+ e_code `snocOL`+ instr (intFormat from) (OpReg reg) (OpReg dst)+ return (Any (intFormat to) code)++ toI8Reg :: Width -> CmmExpr -> NatM Register+ toI8Reg new_rep expr+ = do codefn <- getAnyReg expr+ return (Any (intFormat new_rep) codefn)+ -- HACK: use getAnyReg to get a byte-addressable register.+ -- If the source was a Fixed register, this will add the+ -- mov instruction to put it into the desired destination.+ -- We're assuming that the destination won't be a fixed+ -- non-byte-addressable register; it won't be, because all+ -- fixed registers are word-sized.++ toI16Reg = toI8Reg -- for now++ conversionNop :: Format -> CmmExpr -> NatM Register+ conversionNop new_format expr+ = do e_code <- getRegister' platform is32Bit expr+ return (swizzleRegisterRep e_code new_format)+++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+ MO_F_Gt _ -> condFltReg is32Bit GTT x y+ MO_F_Ge _ -> condFltReg is32Bit GE x y+ -- Invert comparison condition and swap operands+ -- See Note [SSE Parity Checks]+ MO_F_Lt _ -> condFltReg is32Bit GTT y x+ MO_F_Le _ -> condFltReg is32Bit GE y x++ MO_Eq _ -> condIntReg EQQ x y+ MO_Ne _ -> condIntReg NE x y++ MO_S_Gt _ -> condIntReg GTT x y+ MO_S_Ge _ -> condIntReg GE x y+ MO_S_Lt _ -> condIntReg LTT x y+ MO_S_Le _ -> condIntReg LE x y++ MO_U_Gt _ -> condIntReg GU x y+ MO_U_Ge _ -> condIntReg GEU x y+ MO_U_Lt _ -> condIntReg LU x y+ MO_U_Le _ -> condIntReg LEU x y++ MO_F_Add w -> trivialFCode_sse2 w ADD x y++ MO_F_Sub w -> trivialFCode_sse2 w SUB x y++ MO_F_Quot w -> trivialFCode_sse2 w FDIV x y++ MO_F_Mul w -> trivialFCode_sse2 w MUL x y+++ MO_Add rep -> add_code rep x y+ MO_Sub rep -> sub_code rep x y++ MO_S_Quot rep -> div_code rep True True x y+ MO_S_Rem rep -> div_code rep True False x y+ MO_U_Quot rep -> div_code rep False True x y+ MO_U_Rem rep -> div_code rep False False x y++ MO_S_MulMayOflo rep -> imulMayOflo rep x y++ MO_Mul W8 -> imulW8 x y+ MO_Mul rep -> triv_op rep IMUL+ MO_And rep -> triv_op rep AND+ MO_Or rep -> triv_op rep OR+ MO_Xor rep -> triv_op rep XOR++ {- Shift ops on x86s have constraints on their source, it+ either has to be Imm, CL or 1+ => trivialCode is not restrictive enough (sigh.)+ -}+ MO_Shl rep -> shift_code rep SHL x y {-False-}+ MO_U_Shr rep -> shift_code rep SHR x y {-False-}+ MO_S_Shr rep -> shift_code rep SAR x y {-False-}++ MO_V_Insert {} -> needLlvm+ MO_V_Extract {} -> needLlvm+ MO_V_Add {} -> needLlvm+ MO_V_Sub {} -> needLlvm+ MO_V_Mul {} -> needLlvm+ MO_VS_Quot {} -> needLlvm+ MO_VS_Rem {} -> needLlvm+ MO_VS_Neg {} -> needLlvm+ MO_VF_Insert {} -> needLlvm+ MO_VF_Extract {} -> needLlvm+ MO_VF_Add {} -> needLlvm+ MO_VF_Sub {} -> needLlvm+ MO_VF_Mul {} -> needLlvm+ MO_VF_Quot {} -> needLlvm+ MO_VF_Neg {} -> needLlvm++ _other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop)+ where+ --------------------+ triv_op width instr = trivialCode width op (Just op) x y+ where op = instr (intFormat width)++ -- Special case for IMUL for bytes, since the result of IMULB will be in+ -- %ax, the split to %dx/%edx/%rdx and %ax/%eax/%rax happens only for wider+ -- values.+ imulW8 :: CmmExpr -> CmmExpr -> NatM Register+ imulW8 arg_a arg_b = do+ (a_reg, a_code) <- getNonClobberedReg arg_a+ b_code <- getAnyReg arg_b++ let code = a_code `appOL` b_code eax `appOL`+ toOL [ IMUL2 format (OpReg a_reg) ]+ format = intFormat W8++ return (Fixed format eax code)+++ imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register+ imulMayOflo rep a b = do+ (a_reg, a_code) <- getNonClobberedReg a+ b_code <- getAnyReg b+ let+ shift_amt = case rep of+ W32 -> 31+ W64 -> 63+ _ -> panic "shift_amt"++ format = intFormat rep+ code = a_code `appOL` b_code eax `appOL`+ toOL [+ IMUL2 format (OpReg a_reg), -- result in %edx:%eax+ SAR format (OpImm (ImmInt shift_amt)) (OpReg eax),+ -- sign extend lower part+ SUB format (OpReg edx) (OpReg eax)+ -- compare against upper+ -- eax==0 if high part == sign extended low part+ ]+ return (Fixed format eax code)++ --------------------+ shift_code :: Width+ -> (Format -> Operand -> Operand -> Instr)+ -> CmmExpr+ -> CmmExpr+ -> NatM Register++ {- Case1: shift length as immediate -}+ shift_code width instr x (CmmLit lit)+ -- Handle the case of a shift larger than the width of the shifted value.+ -- This is necessary since x86 applies a mask of 0x1f to the shift+ -- amount, meaning that, e.g., `shr 47, $eax` will actually shift by+ -- `47 & 0x1f == 15`. See #20626.+ | CmmInt n _ <- lit+ , n >= fromIntegral (widthInBits width)+ = getRegister $ CmmLit $ CmmInt 0 width++ | otherwise = do+ x_code <- getAnyReg x+ let+ format = intFormat width+ code dst+ = x_code dst `snocOL`+ instr format (OpImm (litToImm lit)) (OpReg dst)+ return (Any format code)++ {- Case2: shift length is complex (non-immediate)+ * y must go in %ecx.+ * we cannot do y first *and* put its result in %ecx, because+ %ecx might be clobbered by x.+ * if we do y second, then x cannot be+ in a clobbered reg. Also, we cannot clobber x's reg+ with the instruction itself.+ * so we can either:+ - do y first, put its result in a fresh tmp, then copy it to %ecx later+ - do y second and put its result into %ecx. x gets placed in a fresh+ tmp. This is likely to be better, because the reg alloc can+ eliminate this reg->reg move here (it won't eliminate the other one,+ because the move is into the fixed %ecx).+ * in the case of C calls the use of ecx here can interfere with arguments.+ We avoid this with the hack described in Note [Evaluate C-call+ arguments before placing in destination registers]+ -}+ shift_code width instr x y{-amount-} = do+ x_code <- getAnyReg x+ let format = intFormat width+ tmp <- getNewRegNat format+ y_code <- getAnyReg y+ let+ code = x_code tmp `appOL`+ y_code ecx `snocOL`+ instr format (OpReg ecx) (OpReg tmp)+ return (Fixed format tmp code)++ --------------------+ add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register+ add_code rep x (CmmLit (CmmInt y _))+ | is32BitInteger y+ , rep /= W8 -- LEA doesn't support byte size (#18614)+ = add_int rep x y+ add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y+ where format = intFormat rep+ -- TODO: There are other interesting patterns we want to replace+ -- with a LEA, e.g. `(x + offset) + (y << shift)`.++ --------------------+ sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register+ sub_code rep x (CmmLit (CmmInt y _))+ | is32BitInteger (-y)+ , rep /= W8 -- LEA doesn't support byte size (#18614)+ = add_int rep x (-y)+ sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y++ -- our three-operand add instruction:+ add_int width x y = do+ (x_reg, x_code) <- getSomeReg x+ let+ format = intFormat width+ imm = ImmInt (fromInteger y)+ code dst+ = x_code `snocOL`+ LEA format+ (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm))+ (OpReg dst)+ --+ return (Any format code)++ ----------------------++ -- See Note [DIV/IDIV for bytes]+ div_code W8 signed quotient x y = do+ let widen | signed = MO_SS_Conv W8 W16+ | otherwise = MO_UU_Conv W8 W16+ div_code+ W16+ signed+ quotient+ (CmmMachOp widen [x])+ (CmmMachOp widen [y])++ div_code width signed quotient x y = do+ (y_op, y_code) <- getRegOrMem y -- cannot be clobbered+ x_code <- getAnyReg x+ let+ format = intFormat width+ widen | signed = CLTD format+ | otherwise = XOR format (OpReg edx) (OpReg edx)++ instr | signed = IDIV+ | otherwise = DIV++ code = y_code `appOL`+ x_code eax `appOL`+ toOL [widen, instr format y_op]++ result | quotient = eax+ | otherwise = edx++ return (Fixed format result code)+++getRegister' _ _ (CmmLoad mem pk _)+ | isFloatType pk+ = do+ Amode addr mem_code <- getAmode mem+ loadFloatAmode (typeWidth pk) addr mem_code++getRegister' _ is32Bit (CmmLoad mem pk _)+ | is32Bit && not (isWord64 pk)+ = do+ code <- intLoadCode instr mem+ return (Any format code)+ where+ width = typeWidth pk+ format = intFormat width+ instr = case width of+ W8 -> MOVZxL II8+ _other -> MOV format+ -- We always zero-extend 8-bit loads, if we+ -- can't think of anything better. This is because+ -- we can't guarantee access to an 8-bit variant of every register+ -- (esi and edi don't have 8-bit variants), so to make things+ -- simpler we do our 8-bit arithmetic with full 32-bit registers.++-- Simpler memory load code on x86_64+getRegister' _ is32Bit (CmmLoad mem pk _)+ | not is32Bit+ = do+ code <- intLoadCode (MOV format) mem+ return (Any format code)+ where format = intFormat $ typeWidth pk++getRegister' _ is32Bit (CmmLit (CmmInt 0 width))+ = let+ format = intFormat width++ -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits+ format1 = if is32Bit then format+ else case format of+ II64 -> II32+ _ -> format+ code dst+ = unitOL (XOR format1 (OpReg dst) (OpReg dst))+ in+ return (Any format code)++ -- optimisation for loading small literals on x86_64: take advantage+ -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit+ -- instruction forms are shorter.+getRegister' platform is32Bit (CmmLit lit)+ | not is32Bit, isWord64 (cmmLitType platform lit), not (isBigLit lit)+ = let+ imm = litToImm lit+ code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst))+ in+ return (Any II64 code)+ where+ isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff+ isBigLit _ = False+ -- note1: not the same as (not.is32BitLit), because that checks for+ -- signed literals that fit in 32 bits, but we want unsigned+ -- literals here.+ -- note2: all labels are small, because we're assuming the+ -- small memory model (see gcc docs, -mcmodel=small).++getRegister' platform _ (CmmLit lit)+ = do let format = cmmTypeFormat (cmmLitType platform lit)+ imm = litToImm lit+ code dst = unitOL (MOV format (OpImm imm) (OpReg dst))+ return (Any format code)++getRegister' platform _ other+ | isVecExpr other = needLlvm+ | otherwise = pprPanic "getRegister(x86)" (pdoc platform other)+++intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr+ -> NatM (Reg -> InstrBlock)+intLoadCode instr mem = do+ Amode src mem_code <- getAmode mem+ return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst))++-- Compute an expression into *any* register, adding the appropriate+-- move instruction if necessary.+getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock)+getAnyReg expr = do+ r <- getRegister expr+ anyReg r++anyReg :: Register -> NatM (Reg -> InstrBlock)+anyReg (Any _ code) = return code+anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg dst)++-- A bit like getSomeReg, but we want a reg that can be byte-addressed.+-- Fixed registers might not be byte-addressable, so we make sure we've+-- got a temporary, inserting an extra reg copy if necessary.+getByteReg :: CmmExpr -> NatM (Reg, InstrBlock)+getByteReg expr = do+ is32Bit <- is32BitPlatform+ if is32Bit+ then do r <- getRegister expr+ case r of+ Any rep code -> do+ tmp <- getNewRegNat rep+ return (tmp, code tmp)+ Fixed rep reg code+ | isVirtualReg reg -> return (reg,code)+ | otherwise -> do+ tmp <- getNewRegNat rep+ return (tmp, code `snocOL` reg2reg rep reg tmp)+ -- ToDo: could optimise slightly by checking for+ -- byte-addressable real registers, but that will+ -- happen very rarely if at all.+ else getSomeReg expr -- all regs are byte-addressable on x86_64++-- Another variant: this time we want the result in a register that cannot+-- be modified by code to evaluate an arbitrary expression.+getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock)+getNonClobberedReg expr = do+ r <- getRegister expr+ platform <- ncgPlatform <$> getConfig+ case r of+ Any rep code -> do+ tmp <- getNewRegNat rep+ return (tmp, code tmp)+ Fixed rep reg code+ -- only certain regs can be clobbered+ | reg `elem` instrClobberedRegs platform+ -> do+ tmp <- getNewRegNat rep+ return (tmp, code `snocOL` reg2reg rep reg tmp)+ | otherwise ->+ return (reg, code)++reg2reg :: Format -> Reg -> Reg -> Instr+reg2reg format src dst = MOV format (OpReg src) (OpReg dst)+++--------------------------------------------------------------------------------++-- | Convert a 'CmmExpr' representing a memory address into an 'Amode'.+--+-- An 'Amode' is a datatype representing a valid address form for the target+-- (e.g. "Base + Index + disp" or immediate) and the code to compute it.+getAmode :: CmmExpr -> NatM Amode+getAmode e = do+ platform <- getPlatform+ let is32Bit = target32Bit platform++ case e of+ CmmRegOff r n+ -> getAmode $ mangleIndexTree platform r n++ CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), CmmLit displacement]+ | not is32Bit+ -> return $ Amode (ripRel (litToImm displacement)) nilOL++ -- This is all just ridiculous, since it carefully undoes+ -- what mangleIndexTree has just done.+ CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)]+ | is32BitLit is32Bit lit+ -- assert (rep == II32)???+ -> do+ (x_reg, x_code) <- getSomeReg x+ let off = ImmInt (-(fromInteger i))+ return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)++ CmmMachOp (MO_Add _rep) [x, CmmLit lit]+ | is32BitLit is32Bit lit+ -- assert (rep == II32)???+ -> do+ (x_reg, x_code) <- getSomeReg x+ let off = litToImm lit+ return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)++ -- Turn (lit1 << n + lit2) into (lit2 + lit1 << n) so it will be+ -- recognised by the next rule.+ CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), b@(CmmLit _)]+ -> getAmode (CmmMachOp (MO_Add rep) [b,a])++ -- Matches: (x + offset) + (y << shift)+ CmmMachOp (MO_Add _) [CmmRegOff x offset, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]+ | shift == 0 || shift == 1 || shift == 2 || shift == 3+ -> x86_complex_amode (CmmReg x) y shift (fromIntegral offset)++ CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]+ | shift == 0 || shift == 1 || shift == 2 || shift == 3+ -> x86_complex_amode x y shift 0++ CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Add _) [CmmMachOp (MO_Shl _)+ [y, CmmLit (CmmInt shift _)], CmmLit (CmmInt offset _)]]+ | shift == 0 || shift == 1 || shift == 2 || shift == 3+ && is32BitInteger offset+ -> x86_complex_amode x y shift offset++ CmmMachOp (MO_Add _) [x,y]+ | not (isLit y) -- we already handle valid literals above.+ -> x86_complex_amode x y 0 0++ CmmLit lit+ | is32BitLit is32Bit lit+ -> return (Amode (ImmAddr (litToImm lit) 0) nilOL)++ -- Literal with offsets too big (> 32 bits) fails during the linking phase+ -- (#15570). We already handled valid literals above so we don't have to+ -- test anything here.+ CmmLit (CmmLabelOff l off)+ -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabel l)+ , CmmLit (CmmInt (fromIntegral off) W64)+ ])+ CmmLit (CmmLabelDiffOff l1 l2 off w)+ -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabelDiffOff l1 l2 0 w)+ , CmmLit (CmmInt (fromIntegral off) W64)+ ])++ -- in case we can't do something better, we just compute the expression+ -- and put the result in a register+ _ -> do+ (reg,code) <- getSomeReg e+ return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code)++++-- | Like 'getAmode', but on 32-bit use simple register addressing+-- (i.e. no index register). This stops us from running out of+-- registers on x86 when using instructions such as cmpxchg, which can+-- use up to three virtual registers and one fixed register.+getSimpleAmode :: CmmExpr -> NatM Amode+getSimpleAmode addr = is32BitPlatform >>= \case+ False -> getAmode addr+ True -> do+ addr_code <- getAnyReg addr+ config <- getConfig+ addr_r <- getNewRegNat (intFormat (ncgWordWidth config))+ let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0)+ return $! Amode amode (addr_code addr_r)++x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode+x86_complex_amode base index shift offset+ = do (x_reg, x_code) <- getNonClobberedReg base+ -- x must be in a temp, because it has to stay live over y_code+ -- we could compare x_reg and y_reg and do something better here...+ (y_reg, y_code) <- getSomeReg index+ let+ code = x_code `appOL` y_code+ base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8;+ n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")"+ return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset)))+ code)+++++-- -----------------------------------------------------------------------------+-- getOperand: sometimes any operand will do.++-- getNonClobberedOperand: the value of the operand will remain valid across+-- the computation of an arbitrary expression, unless the expression+-- is computed directly into a register which the operand refers to+-- (see trivialCode where this function is used for an example).++getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)+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 return (OpImm (litToImm lit), nilOL)+ else getNonClobberedOperand_generic (CmmLit lit)++getNonClobberedOperand (CmmLoad mem pk _) = do+ is32Bit <- is32BitPlatform+ -- this logic could be simplified+ -- TODO FIXME+ if (if is32Bit then not (isWord64 pk) else True)+ -- if 32bit and pk is at float/double/simd value+ -- or if 64bit+ -- this could use some eyeballs or i'll need to stare at it more later+ then do+ platform <- ncgPlatform <$> getConfig+ Amode src mem_code <- getAmode mem+ (src',save_code) <-+ if (amodeCouldBeClobbered platform src)+ then do+ tmp <- getNewRegNat (archWordFormat is32Bit)+ return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0),+ unitOL (LEA (archWordFormat is32Bit)+ (OpAddr src)+ (OpReg tmp)))+ else+ return (src, nilOL)+ return (OpAddr src', mem_code `appOL` save_code)+ else+ -- if its a word or gcptr on 32bit?+ getNonClobberedOperand_generic (CmmLoad mem pk NaturallyAligned)++getNonClobberedOperand e = getNonClobberedOperand_generic e++getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)+getNonClobberedOperand_generic e = do+ (reg, code) <- getNonClobberedReg e+ return (OpReg reg, code)++amodeCouldBeClobbered :: Platform -> AddrMode -> Bool+amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode)++regClobbered :: Platform -> Reg -> Bool+regClobbered platform (RegReal (RealRegSingle rr)) = freeReg platform rr+regClobbered _ _ = False++-- getOperand: the operand is not required to remain valid across the+-- computation of an arbitrary expression.+getOperand :: CmmExpr -> NatM (Operand, InstrBlock)++getOperand (CmmLit lit) = do+ use_sse2 <- sse2Enabled+ if (use_sse2 && 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 return (OpImm (litToImm lit), nilOL)+ else getOperand_generic (CmmLit lit)++getOperand (CmmLoad mem pk _) = do+ is32Bit <- is32BitPlatform+ use_sse2 <- sse2Enabled+ if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)+ then do+ Amode src mem_code <- getAmode mem+ return (OpAddr src, mem_code)+ else+ getOperand_generic (CmmLoad mem pk NaturallyAligned)++getOperand e = getOperand_generic e++getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)+getOperand_generic e = do+ (reg, code) <- getSomeReg e+ return (OpReg reg, code)++isOperand :: Bool -> CmmExpr -> Bool+isOperand _ (CmmLoad _ _ _) = True+isOperand is32Bit (CmmLit lit) = is32BitLit is32Bit lit+ || isSuitableFloatingPointLit lit+isOperand _ _ = False++-- | Given a 'Register', produce a new 'Register' with an instruction block+-- which will check the value for alignment. Used for @-falignment-sanitisation@.+addAlignmentCheck :: Int -> Register -> Register+addAlignmentCheck align reg =+ case reg of+ Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt reg)+ Any fmt f -> Any fmt (\reg -> f reg `appOL` check fmt reg)+ where+ check :: Format -> Reg -> InstrBlock+ check fmt reg =+ assert (not $ isFloatFormat fmt) $+ toOL [ TEST fmt (OpImm $ ImmInt $ align-1) (OpReg reg)+ , JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel+ ]++memConstant :: Alignment -> CmmLit -> NatM Amode+memConstant align lit = do+ lbl <- getNewLabelNat+ let rosection = Section ReadOnlyData lbl+ config <- getConfig+ platform <- getPlatform+ (addr, addr_code) <- if target32Bit platform+ then do dynRef <- cmmMakeDynamicReference+ config+ DataReference+ lbl+ Amode addr addr_code <- getAmode dynRef+ return (addr, addr_code)+ else return (ripRel (ImmCLbl lbl), nilOL)+ let code =+ LDATA rosection (align, CmmStaticsRaw lbl [CmmStaticLit lit])+ `consOL` addr_code+ return (Amode addr code)+++loadFloatAmode :: Width -> AddrMode -> InstrBlock -> NatM Register+loadFloatAmode w addr addr_code = do+ let format = floatFormat w+ code dst = addr_code `snocOL`+ MOV format (OpAddr addr) (OpReg dst)++ return (Any format code)+++-- if we want a floating-point literal as an operand, we can+-- use it directly from memory. However, if the literal is+-- zero, we're better off generating it into a register using+-- xor.+isSuitableFloatingPointLit :: CmmLit -> Bool+isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0+isSuitableFloatingPointLit _ = False++getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)+getRegOrMem e@(CmmLoad mem pk _) = do+ is32Bit <- is32BitPlatform+ use_sse2 <- sse2Enabled+ if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)+ then do+ Amode src mem_code <- getAmode mem+ return (OpAddr src, mem_code)+ else do+ (reg, code) <- getNonClobberedReg e+ return (OpReg reg, code)+getRegOrMem e = do+ (reg, code) <- getNonClobberedReg e+ return (OpReg reg, code)++is32BitLit :: Bool -> CmmLit -> Bool+is32BitLit is32Bit lit+ | not is32Bit = case lit of+ CmmInt i W64 -> is32BitInteger i+ -- assume that labels are in the range 0-2^31-1: this assumes the+ -- small memory model (see gcc docs, -mcmodel=small).+ CmmLabel _ -> True+ -- however we can't assume that label offsets are in this range+ -- (see #15570)+ CmmLabelOff _ off -> is32BitInteger (fromIntegral off)+ CmmLabelDiffOff _ _ off _ -> is32BitInteger (fromIntegral off)+ _ -> True+is32BitLit _ _ = True+++++-- Set up a condition code for a conditional branch.++getCondCode :: CmmExpr -> NatM CondCode++-- yes, they really do seem to want exactly the same!++getCondCode (CmmMachOp mop [x, y])+ =+ 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+ MO_F_Ge W32 -> condFltCode GE x y+ -- Invert comparison condition and swap operands+ -- See Note [SSE Parity Checks]+ MO_F_Lt W32 -> condFltCode GTT y x+ MO_F_Le W32 -> condFltCode GE y x++ MO_F_Eq W64 -> condFltCode EQQ x y+ MO_F_Ne W64 -> condFltCode NE x y+ MO_F_Gt W64 -> condFltCode GTT x y+ MO_F_Ge W64 -> condFltCode GE x y+ MO_F_Lt W64 -> condFltCode GTT y x+ MO_F_Le W64 -> condFltCode GE y x++ _ -> condIntCode (machOpToCond mop) x y++getCondCode other = do+ platform <- getPlatform+ pprPanic "getCondCode(2)(x86,x86_64)" (pdoc platform other)++machOpToCond :: MachOp -> Cond+machOpToCond mo = case mo of+ MO_Eq _ -> EQQ+ MO_Ne _ -> NE+ MO_S_Gt _ -> GTT+ MO_S_Ge _ -> GE+ MO_S_Lt _ -> LTT+ MO_S_Le _ -> LE+ MO_U_Gt _ -> GU+ MO_U_Ge _ -> GEU+ MO_U_Lt _ -> LU+ MO_U_Le _ -> LEU+ _other -> pprPanic "machOpToCond" (pprMachOp mo)+++-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be+-- passed back up the tree.++condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode+condIntCode cond x y = do is32Bit <- is32BitPlatform+ condIntCode' is32Bit cond x y++condIntCode' :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode++-- memory vs immediate+condIntCode' is32Bit cond (CmmLoad x pk _) (CmmLit lit)+ | is32BitLit is32Bit lit = do+ Amode x_addr x_code <- getAmode x+ let+ imm = litToImm lit+ code = x_code `snocOL`+ CMP (cmmTypeFormat pk) (OpImm imm) (OpAddr x_addr)+ --+ return (CondCode False cond code)++-- anything vs zero, using a mask+-- TODO: Add some sanity checking!!!!+condIntCode' is32Bit cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 pk))+ | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit is32Bit lit+ = do+ (x_reg, x_code) <- getSomeReg x+ let+ code = x_code `snocOL`+ TEST (intFormat pk) (OpImm (ImmInteger mask)) (OpReg x_reg)+ --+ return (CondCode False cond code)++-- anything vs zero+condIntCode' _ cond x (CmmLit (CmmInt 0 pk)) = do+ (x_reg, x_code) <- getSomeReg x+ let+ code = x_code `snocOL`+ TEST (intFormat pk) (OpReg x_reg) (OpReg x_reg)+ --+ return (CondCode False cond code)++-- anything vs operand+condIntCode' is32Bit cond x y+ | isOperand is32Bit y = do+ platform <- getPlatform+ (x_reg, x_code) <- getNonClobberedReg x+ (y_op, y_code) <- getOperand y+ let+ code = x_code `appOL` y_code `snocOL`+ CMP (cmmTypeFormat (cmmExprType platform x)) y_op (OpReg x_reg)+ return (CondCode False cond code)+-- operand vs. anything: invert the comparison so that we can use a+-- single comparison instruction.+ | isOperand is32Bit x+ , Just revcond <- maybeFlipCond cond = do+ platform <- getPlatform+ (y_reg, y_code) <- getNonClobberedReg y+ (x_op, x_code) <- getOperand x+ let+ code = y_code `appOL` x_code `snocOL`+ CMP (cmmTypeFormat (cmmExprType platform x)) x_op (OpReg y_reg)+ return (CondCode False revcond code)++-- anything vs anything+condIntCode' _ cond x y = do+ platform <- getPlatform+ (y_reg, y_code) <- getNonClobberedReg y+ (x_op, x_code) <- getRegOrMem x+ let+ code = y_code `appOL`+ x_code `snocOL`+ CMP (cmmTypeFormat (cmmExprType platform x)) (OpReg y_reg) x_op+ return (CondCode False cond code)++++--------------------------------------------------------------------------------+condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode++condFltCode cond x y+ = condFltCode_sse2+ where+++ -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be+ -- an operand, but the right must be a reg. We can probably do better+ -- than this general case...+ condFltCode_sse2 = do+ platform <- getPlatform+ (x_reg, x_code) <- getNonClobberedReg x+ (y_op, y_code) <- getOperand y+ let+ code = x_code `appOL`+ y_code `snocOL`+ CMP (floatFormat $ cmmExprWidth platform x) y_op (OpReg x_reg)+ -- NB(1): we need to use the unsigned comparison operators on the+ -- result of this comparison.+ return (CondCode True (condToUnsigned cond) code)++-- -----------------------------------------------------------------------------+-- Generating assignments++-- Assignments are really at the heart of the whole code generation+-- business. Almost all top-level nodes of any real importance are+-- assignments, which correspond to loads, stores, or register+-- transfers. If we're really lucky, some of the register transfers+-- will go away, because we can use the destination register to+-- complete the code generation for the right hand side. This only+-- fails when the right hand side is forced into a fixed register+-- (e.g. the result of a call).++assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock++assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock+++-- integer assignment to memory++-- specific case of adding/subtracting an integer to a particular address.+-- ToDo: catch other cases where we can use an operation directly on a memory+-- address.+assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _ _,+ CmmLit (CmmInt i _)])+ | addr == addr2, pk /= II64 || is32BitInteger i,+ Just instr <- check op+ = do Amode amode code_addr <- getAmode addr+ let code = code_addr `snocOL`+ instr pk (OpImm (ImmInt (fromIntegral i))) (OpAddr amode)+ return code+ where+ check (MO_Add _) = Just ADD+ check (MO_Sub _) = Just SUB+ check _ = Nothing+ -- ToDo: more?++-- general case+assignMem_IntCode pk addr src = do+ is32Bit <- is32BitPlatform+ Amode addr code_addr <- getAmode addr+ (code_src, op_src) <- get_op_RI is32Bit src+ let+ code = code_src `appOL`+ code_addr `snocOL`+ MOV pk op_src (OpAddr addr)+ -- NOTE: op_src is stable, so it will still be valid+ -- after code_addr. This may involve the introduction+ -- of an extra MOV to a temporary register, but we hope+ -- the register allocator will get rid of it.+ --+ return code+ where+ get_op_RI :: Bool -> CmmExpr -> NatM (InstrBlock,Operand) -- code, operator+ get_op_RI is32Bit (CmmLit lit) | is32BitLit is32Bit lit+ = return (nilOL, OpImm (litToImm lit))+ get_op_RI _ op+ = do (reg,code) <- getNonClobberedReg op+ return (code, OpReg reg)+++-- Assign; dst is a reg, rhs is mem+assignReg_IntCode pk reg (CmmLoad src _ _) = do+ load_code <- intLoadCode (MOV pk) src+ platform <- ncgPlatform <$> getConfig+ return (load_code (getRegisterReg platform reg))++-- dst is a reg, but src could be anything+assignReg_IntCode _ reg src = do+ platform <- ncgPlatform <$> getConfig+ code <- getAnyReg src+ return (code (getRegisterReg platform reg))+++-- Floating point assignment to memory+assignMem_FltCode pk addr src = do+ (src_reg, src_code) <- getNonClobberedReg src+ Amode addr addr_code <- getAmode addr+ let+ code = src_code `appOL`+ addr_code `snocOL`+ MOV pk (OpReg src_reg) (OpAddr addr)++ return code++-- Floating point assignment to a register/temporary+assignReg_FltCode _ reg src = do+ src_code <- getAnyReg src+ platform <- ncgPlatform <$> getConfig+ return (src_code (getRegisterReg platform reg))+++genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock++genJump (CmmLoad mem _ _) regs = do+ Amode target code <- getAmode mem+ return (code `snocOL` JMP (OpAddr target) regs)++genJump (CmmLit lit) regs =+ return (unitOL (JMP (OpImm (litToImm lit)) regs))++genJump expr regs = do+ (reg,code) <- getSomeReg expr+ return (code `snocOL` JMP (OpReg reg) regs)+++-- -----------------------------------------------------------------------------+-- Unconditional branches++genBranch :: BlockId -> InstrBlock+genBranch = toOL . mkJumpInstr++++-- -----------------------------------------------------------------------------+-- Conditional jumps/branches++{-+Conditional jumps are always to local labels, so we can use branch+instructions. We peek at the arguments to decide what kind of+comparison to do.++I386: First, we have to ensure that the condition+codes are set according to the supplied comparison operation.+-}++{- Note [64-bit integer comparisons on 32-bit]+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++ When doing these comparisons there are 2 kinds of+ comparisons.++ * Comparison for equality (or lack thereof)++ We use xor to check if high/low bits are+ equal. Then combine the results using or and+ perform a single conditional jump based on the+ result.++ * Other comparisons:++ We map all other comparisons to the >= operation.+ Why? Because it's easy to encode it with a single+ conditional jump.++ We do this by first computing [r1_lo - r2_lo]+ and use the carry flag to compute+ [r1_high - r2_high - CF].++ At which point if r1 >= r2 then the result will be+ positive. Otherwise negative so we can branch on this+ condition.++-}+++genCondBranch+ :: BlockId -- the source of the jump+ -> BlockId -- the true branch target+ -> BlockId -- the false branch target+ -> CmmExpr -- the condition on which to branch+ -> NatM InstrBlock -- Instructions++genCondBranch bid id false expr = do+ is32Bit <- is32BitPlatform+ genCondBranch' is32Bit bid id false expr++-- | We return the instructions generated.+genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr+ -> NatM InstrBlock++-- 64-bit integer comparisons on 32-bit+-- See Note [64-bit integer comparisons on 32-bit]+genCondBranch' is32Bit _bid true false (CmmMachOp mop [e1,e2])+ | is32Bit, Just W64 <- maybeIntComparison mop = do++ RegCode64 code1 r1hi r1lo <- iselExpr64 e1+ RegCode64 code2 r2hi r2lo <- iselExpr64 e2+ let cond = machOpToCond mop :: Cond++ -- we mustn't clobber r1/r2 so we use temporaries+ tmp1 <- getNewRegNat II32+ tmp2 <- getNewRegNat II32++ let cmpCode = intComparison cond true false r1hi r1lo r2hi r2lo tmp1 tmp2+ return $ code1 `appOL` code2 `appOL` cmpCode++ where+ intComparison cond true false r1_hi r1_lo r2_hi r2_lo tmp1 tmp2 =+ case cond of+ -- Impossible results of machOpToCond+ ALWAYS -> panic "impossible"+ NEG -> panic "impossible"+ POS -> panic "impossible"+ CARRY -> panic "impossible"+ OFLO -> panic "impossible"+ PARITY -> panic "impossible"+ NOTPARITY -> panic "impossible"+ -- Special case #1 x == y and x != y+ EQQ -> cmpExact+ NE -> cmpExact+ -- [x >= y]+ GE -> cmpGE+ GEU -> cmpGE+ -- [x > y] <==> ![y >= x]+ GTT -> intComparison GE false true r2_hi r2_lo r1_hi r1_lo tmp1 tmp2+ GU -> intComparison GEU false true r2_hi r2_lo r1_hi r1_lo tmp1 tmp2+ -- [x <= y] <==> [y >= x]+ LE -> intComparison GE true false r2_hi r2_lo r1_hi r1_lo tmp1 tmp2+ LEU -> intComparison GEU true false r2_hi r2_lo r1_hi r1_lo tmp1 tmp2+ -- [x < y] <==> ![x >= x]+ LTT -> intComparison GE false true r1_hi r1_lo r2_hi r2_lo tmp1 tmp2+ LU -> intComparison GEU false true r1_hi r1_lo r2_hi r2_lo tmp1 tmp2+ where+ cmpExact :: OrdList Instr+ cmpExact =+ toOL+ [ MOV II32 (OpReg r1_hi) (OpReg tmp1)+ , MOV II32 (OpReg r1_lo) (OpReg tmp2)+ , XOR II32 (OpReg r2_hi) (OpReg tmp1)+ , XOR II32 (OpReg r2_lo) (OpReg tmp2)+ , OR II32 (OpReg tmp1) (OpReg tmp2)+ , JXX cond true+ , JXX ALWAYS false+ ]+ cmpGE = toOL+ [ MOV II32 (OpReg r1_hi) (OpReg tmp1)+ , CMP II32 (OpReg r2_lo) (OpReg r1_lo)+ , SBB II32 (OpReg r2_hi) (OpReg tmp1)+ , JXX cond true+ , JXX ALWAYS false ]++genCondBranch' _ bid id false bool = do+ CondCode is_float cond cond_code <- getCondCode bool+ use_sse2 <- sse2Enabled+ if not is_float || not use_sse2+ then+ return (cond_code `snocOL` JXX cond id `appOL` genBranch false)+ else do+ -- See Note [SSE Parity Checks]+ let jmpFalse = genBranch false+ code+ = case cond of+ NE -> or_unordered+ GU -> plain_test+ GEU -> plain_test+ -- Use ASSERT so we don't break releases if+ -- LTT/LE creep in somehow.+ LTT ->+ assertPpr False (ppr "Should have been turned into >")+ and_ordered+ LE ->+ assertPpr False (ppr "Should have been turned into >=")+ and_ordered+ _ -> and_ordered++ plain_test = unitOL (+ JXX cond id+ ) `appOL` jmpFalse+ or_unordered = toOL [+ JXX cond id,+ JXX PARITY id+ ] `appOL` jmpFalse+ and_ordered = toOL [+ JXX PARITY false,+ JXX cond id,+ JXX ALWAYS false+ ]+ updateCfgNat (\cfg -> adjustEdgeWeight cfg (+3) bid false)+ return (cond_code `appOL` code)++{- Note [Introducing cfg edges inside basic blocks]+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++ During instruction selection a statement `s`+ in a block B with control of the sort: B -> C+ will sometimes result in control+ flow of the sort:++ ┌ < ┐+ v ^+ B -> B1 ┴ -> C++ as is the case for some atomic operations.++ Now to keep the CFG in sync when introducing B1 we clearly+ want to insert it between B and C. However there is+ a catch when we have to deal with self loops.++ We might start with code and a CFG of these forms:++ loop:+ stmt1 ┌ < ┐+ .... v ^+ stmtX loop ┘+ stmtY+ ....+ goto loop:++ Now we introduce B1:+ ┌ ─ ─ ─ ─ ─┐+ loop: │ ┌ < ┐ │+ instrs v │ │ ^+ .... loop ┴ B1 ┴ ┘+ instrsFromX+ stmtY+ goto loop:++ This is simple, all outgoing edges from loop now simply+ start from B1 instead and the code generator knows which+ new edges it introduced for the self loop of B1.++ Disaster strikes if the statement Y follows the same pattern.+ If we apply the same rule that all outgoing edges change then+ we end up with:++ loop ─> B1 ─> B2 ┬─┐+ │ │ └─<┤ │+ │ └───<───┘ │+ └───────<────────┘++ This is problematic. The edge B1->B1 is modified as expected.+ However the modification is wrong!++ The assembly in this case looked like this:++ _loop:+ <instrs>+ _B1:+ ...+ cmpxchgq ...+ jne _B1+ <instrs>+ <end _B1>+ _B2:+ ...+ cmpxchgq ...+ jne _B2+ <instrs>+ jmp loop++ There is no edge _B2 -> _B1 here. It's still a self loop onto _B1.++ The problem here is that really B1 should be two basic blocks.+ Otherwise we have control flow in the *middle* of a basic block.+ A contradiction!++ So to account for this we add yet another basic block marker:++ _B:+ <instrs>+ _B1:+ ...+ cmpxchgq ...+ jne _B1+ jmp _B1'+ _B1':+ <instrs>+ <end _B1>+ _B2:+ ...++ Now when inserting B2 we will only look at the outgoing edges of B1' and+ everything will work out nicely.++ You might also wonder why we don't insert jumps at the end of _B1'. There is+ no way another block ends up jumping to the labels _B1 or _B2 since they are+ essentially invisible to other blocks. View them as control flow labels local+ to the basic block if you'd like.++ Not doing this ultimately caused (part 2 of) #17334.+-}+++-- -----------------------------------------------------------------------------+-- Generating C calls++-- Now the biggest nightmare---calls. Most of the nastiness is buried in+-- @get_arg@, which moves the arguments to the correct registers/stack+-- locations. Apart from that, the code is easy.+--+-- (If applicable) Do not fill the delay slots here; you will confuse the+-- register allocator.+--+-- See Note [Keeping track of the current block] for information why we need+-- to take/return a block id.++genForeignCall+ :: ForeignTarget -- ^ function to call+ -> [CmmFormal] -- ^ where to put the result+ -> [CmmActual] -- ^ arguments (of mixed type)+ -> BlockId -- ^ The block we are in+ -> NatM (InstrBlock, Maybe BlockId)++genForeignCall target dst args bid = do+ case target of+ PrimTarget prim -> genPrim bid prim dst args+ ForeignTarget addr conv -> (,Nothing) <$> genCCall bid addr conv dst args++genPrim+ :: BlockId -- ^ The block we are in+ -> CallishMachOp -- ^ MachOp+ -> [CmmFormal] -- ^ where to put the result+ -> [CmmActual] -- ^ arguments (of mixed type)+ -> NatM (InstrBlock, Maybe BlockId)++-- First we deal with cases which might introduce new blocks in the stream.+genPrim bid (MO_AtomicRMW width amop) [dst] [addr, n]+ = genAtomicRMW bid width amop dst addr n+genPrim bid (MO_Ctz width) [dst] [src]+ = genCtz bid width dst src++-- Then we deal with cases which not introducing new blocks in the stream.+genPrim bid prim dst args+ = (,Nothing) <$> genSimplePrim bid prim dst args++genSimplePrim+ :: BlockId -- ^ the block we are in+ -> CallishMachOp -- ^ MachOp+ -> [CmmFormal] -- ^ where to put the result+ -> [CmmActual] -- ^ arguments (of mixed type)+ -> NatM InstrBlock+genSimplePrim bid (MO_Memcpy align) [] [dst,src,n] = genMemCpy bid align dst src n+genSimplePrim bid (MO_Memmove align) [] [dst,src,n] = genMemMove bid align dst src n+genSimplePrim bid (MO_Memcmp align) [res] [dst,src,n] = genMemCmp bid align res dst src n+genSimplePrim bid (MO_Memset align) [] [dst,c,n] = genMemSet bid align dst c n+genSimplePrim _ MO_ReadBarrier [] [] = return nilOL -- barriers compile to no code on x86/x86-64;+genSimplePrim _ MO_WriteBarrier [] [] = return nilOL -- we keep it this long in order to prevent earlier optimisations.+genSimplePrim _ MO_Touch [] [_] = return nilOL+genSimplePrim _ (MO_Prefetch_Data n) [] [src] = genPrefetchData n src+genSimplePrim _ (MO_BSwap width) [dst] [src] = genByteSwap width dst src+genSimplePrim bid (MO_BRev width) [dst] [src] = genBitRev bid width dst src+genSimplePrim bid (MO_PopCnt width) [dst] [src] = genPopCnt bid width dst src+genSimplePrim bid (MO_Pdep width) [dst] [src,mask] = genPdep bid width dst src mask+genSimplePrim bid (MO_Pext width) [dst] [src,mask] = genPext bid width dst src mask+genSimplePrim bid (MO_Clz width) [dst] [src] = genClz bid width dst src+genSimplePrim bid (MO_UF_Conv width) [dst] [src] = genWordToFloat bid width dst src+genSimplePrim _ (MO_AtomicRead w) [dst] [addr] = genAtomicRead w dst addr+genSimplePrim _ (MO_AtomicWrite w) [] [addr,val] = genAtomicWrite w addr val+genSimplePrim bid (MO_Cmpxchg width) [dst] [addr,old,new] = genCmpXchg bid width dst addr old new+genSimplePrim _ (MO_Xchg width) [dst] [addr, value] = genXchg width dst addr value+genSimplePrim _ (MO_AddWordC w) [r,c] [x,y] = genAddSubRetCarry w ADD_CC (const Nothing) CARRY r c x y+genSimplePrim _ (MO_SubWordC w) [r,c] [x,y] = genAddSubRetCarry w SUB_CC (const Nothing) CARRY r c x y+genSimplePrim _ (MO_AddIntC w) [r,c] [x,y] = genAddSubRetCarry w ADD_CC (Just . ADD_CC) OFLO r c x y+genSimplePrim _ (MO_SubIntC w) [r,c] [x,y] = genAddSubRetCarry w SUB_CC (const Nothing) OFLO r c x y+genSimplePrim _ (MO_Add2 w) [h,l] [x,y] = genAddWithCarry w h l x y+genSimplePrim _ (MO_U_Mul2 w) [h,l] [x,y] = genUnsignedLargeMul w h l x y+genSimplePrim _ (MO_S_Mul2 w) [c,h,l] [x,y] = genSignedLargeMul w c h l x y+genSimplePrim _ (MO_S_QuotRem w) [q,r] [x,y] = genQuotRem w True q r Nothing x y+genSimplePrim _ (MO_U_QuotRem w) [q,r] [x,y] = genQuotRem w False q r Nothing x y+genSimplePrim _ (MO_U_QuotRem2 w) [q,r] [hx,lx,y] = genQuotRem w False q r (Just hx) lx y+genSimplePrim _ MO_F32_Fabs [dst] [src] = genFloatAbs W32 dst src+genSimplePrim _ MO_F64_Fabs [dst] [src] = genFloatAbs W64 dst src+genSimplePrim _ MO_F32_Sqrt [dst] [src] = genFloatSqrt FF32 dst src+genSimplePrim _ MO_F64_Sqrt [dst] [src] = genFloatSqrt FF64 dst src+genSimplePrim bid MO_F32_Sin [dst] [src] = genLibCCall bid (fsLit "sinf") [dst] [src]+genSimplePrim bid MO_F32_Cos [dst] [src] = genLibCCall bid (fsLit "cosf") [dst] [src]+genSimplePrim bid MO_F32_Tan [dst] [src] = genLibCCall bid (fsLit "tanf") [dst] [src]+genSimplePrim bid MO_F32_Exp [dst] [src] = genLibCCall bid (fsLit "expf") [dst] [src]+genSimplePrim bid MO_F32_ExpM1 [dst] [src] = genLibCCall bid (fsLit "expm1f") [dst] [src]+genSimplePrim bid MO_F32_Log [dst] [src] = genLibCCall bid (fsLit "logf") [dst] [src]+genSimplePrim bid MO_F32_Log1P [dst] [src] = genLibCCall bid (fsLit "log1pf") [dst] [src]+genSimplePrim bid MO_F32_Asin [dst] [src] = genLibCCall bid (fsLit "asinf") [dst] [src]+genSimplePrim bid MO_F32_Acos [dst] [src] = genLibCCall bid (fsLit "acosf") [dst] [src]+genSimplePrim bid MO_F32_Atan [dst] [src] = genLibCCall bid (fsLit "atanf") [dst] [src]+genSimplePrim bid MO_F32_Sinh [dst] [src] = genLibCCall bid (fsLit "sinhf") [dst] [src]+genSimplePrim bid MO_F32_Cosh [dst] [src] = genLibCCall bid (fsLit "coshf") [dst] [src]+genSimplePrim bid MO_F32_Tanh [dst] [src] = genLibCCall bid (fsLit "tanhf") [dst] [src]+genSimplePrim bid MO_F32_Pwr [dst] [x,y] = genLibCCall bid (fsLit "powf") [dst] [x,y]+genSimplePrim bid MO_F32_Asinh [dst] [src] = genLibCCall bid (fsLit "asinhf") [dst] [src]+genSimplePrim bid MO_F32_Acosh [dst] [src] = genLibCCall bid (fsLit "acoshf") [dst] [src]+genSimplePrim bid MO_F32_Atanh [dst] [src] = genLibCCall bid (fsLit "atanhf") [dst] [src]+genSimplePrim bid MO_F64_Sin [dst] [src] = genLibCCall bid (fsLit "sin") [dst] [src]+genSimplePrim bid MO_F64_Cos [dst] [src] = genLibCCall bid (fsLit "cos") [dst] [src]+genSimplePrim bid MO_F64_Tan [dst] [src] = genLibCCall bid (fsLit "tan") [dst] [src]+genSimplePrim bid MO_F64_Exp [dst] [src] = genLibCCall bid (fsLit "exp") [dst] [src]+genSimplePrim bid MO_F64_ExpM1 [dst] [src] = genLibCCall bid (fsLit "expm1") [dst] [src]+genSimplePrim bid MO_F64_Log [dst] [src] = genLibCCall bid (fsLit "log") [dst] [src]+genSimplePrim bid MO_F64_Log1P [dst] [src] = genLibCCall bid (fsLit "log1p") [dst] [src]+genSimplePrim bid MO_F64_Asin [dst] [src] = genLibCCall bid (fsLit "asin") [dst] [src]+genSimplePrim bid MO_F64_Acos [dst] [src] = genLibCCall bid (fsLit "acos") [dst] [src]+genSimplePrim bid MO_F64_Atan [dst] [src] = genLibCCall bid (fsLit "atan") [dst] [src]+genSimplePrim bid MO_F64_Sinh [dst] [src] = genLibCCall bid (fsLit "sinh") [dst] [src]+genSimplePrim bid MO_F64_Cosh [dst] [src] = genLibCCall bid (fsLit "cosh") [dst] [src]+genSimplePrim bid MO_F64_Tanh [dst] [src] = genLibCCall bid (fsLit "tanh") [dst] [src]+genSimplePrim bid MO_F64_Pwr [dst] [x,y] = genLibCCall bid (fsLit "pow") [dst] [x,y]+genSimplePrim bid MO_F64_Asinh [dst] [src] = genLibCCall bid (fsLit "asinh") [dst] [src]+genSimplePrim bid MO_F64_Acosh [dst] [src] = genLibCCall bid (fsLit "acosh") [dst] [src]+genSimplePrim bid MO_F64_Atanh [dst] [src] = genLibCCall bid (fsLit "atanh") [dst] [src]+genSimplePrim bid MO_SuspendThread [tok] [rs,i] = genRTSCCall bid (fsLit "suspendThread") [tok] [rs,i]+genSimplePrim bid MO_ResumeThread [rs] [tok] = genRTSCCall bid (fsLit "resumeThread") [rs] [tok]+genSimplePrim _ MO_I64_ToI [dst] [src] = genInt64ToInt dst src+genSimplePrim _ MO_I64_FromI [dst] [src] = genIntToInt64 dst src+genSimplePrim _ MO_W64_ToW [dst] [src] = genWord64ToWord dst src+genSimplePrim _ MO_W64_FromW [dst] [src] = genWordToWord64 dst src+genSimplePrim _ MO_x64_Neg [dst] [src] = genNeg64 dst src+genSimplePrim _ MO_x64_Add [dst] [x,y] = genAdd64 dst x y+genSimplePrim _ MO_x64_Sub [dst] [x,y] = genSub64 dst x y+genSimplePrim bid MO_x64_Mul [dst] [x,y] = genPrimCCall bid (fsLit "hs_mul64") [dst] [x,y]+genSimplePrim bid MO_I64_Quot [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotInt64") [dst] [x,y]+genSimplePrim bid MO_I64_Rem [dst] [x,y] = genPrimCCall bid (fsLit "hs_remInt64") [dst] [x,y]+genSimplePrim bid MO_W64_Quot [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotWord64") [dst] [x,y]+genSimplePrim bid MO_W64_Rem [dst] [x,y] = genPrimCCall bid (fsLit "hs_remWord64") [dst] [x,y]+genSimplePrim _ MO_x64_And [dst] [x,y] = genAnd64 dst x y+genSimplePrim _ MO_x64_Or [dst] [x,y] = genOr64 dst x y+genSimplePrim _ MO_x64_Xor [dst] [x,y] = genXor64 dst x y+genSimplePrim _ MO_x64_Not [dst] [src] = genNot64 dst src+genSimplePrim bid MO_x64_Shl [dst] [x,n] = genPrimCCall bid (fsLit "hs_uncheckedShiftL64") [dst] [x,n]+genSimplePrim bid MO_I64_Shr [dst] [x,n] = genPrimCCall bid (fsLit "hs_uncheckedIShiftRA64") [dst] [x,n]+genSimplePrim bid MO_W64_Shr [dst] [x,n] = genPrimCCall bid (fsLit "hs_uncheckedShiftRL64") [dst] [x,n]+genSimplePrim _ MO_x64_Eq [dst] [x,y] = genEq64 dst x y+genSimplePrim _ MO_x64_Ne [dst] [x,y] = genNe64 dst x y+genSimplePrim _ MO_I64_Ge [dst] [x,y] = genGeInt64 dst x y+genSimplePrim _ MO_I64_Gt [dst] [x,y] = genGtInt64 dst x y+genSimplePrim _ MO_I64_Le [dst] [x,y] = genLeInt64 dst x y+genSimplePrim _ MO_I64_Lt [dst] [x,y] = genLtInt64 dst x y+genSimplePrim _ MO_W64_Ge [dst] [x,y] = genGeWord64 dst x y+genSimplePrim _ MO_W64_Gt [dst] [x,y] = genGtWord64 dst x y+genSimplePrim _ MO_W64_Le [dst] [x,y] = genLeWord64 dst x y+genSimplePrim _ MO_W64_Lt [dst] [x,y] = genLtWord64 dst x y+genSimplePrim _ op dst args = do+ platform <- ncgPlatform <$> getConfig+ pprPanic "genSimplePrim: unhandled primop" (ppr (pprCallishMachOp op, dst, fmap (pdoc platform) args))++{-+Note [Evaluate C-call arguments before placing in destination registers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When producing code for C calls we must take care when placing arguments+in their final registers. Specifically, we must ensure that temporary register+usage due to evaluation of one argument does not clobber a register in which we+already placed a previous argument (e.g. as the code generation logic for+MO_Shl can clobber %rcx due to x86 instruction limitations).++This is precisely what happened in #18527. Consider this C--:++ (result::I64) = call "ccall" doSomething(_s2hp::I64, 2244, _s2hq::I64, _s2hw::I64 | (1 << _s2hz::I64));++Here we are calling the C function `doSomething` with three arguments, the last+involving a non-trivial expression involving MO_Shl. In this case the NCG could+naively generate the following assembly (where $tmp denotes some temporary+register and $argN denotes the register for argument N, as dictated by the+platform's calling convention):++ mov _s2hp, $arg1 # place first argument+ mov _s2hq, $arg2 # place second argument++ # Compute 1 << _s2hz+ mov _s2hz, %rcx+ shl %cl, $tmp++ # Compute (_s2hw | (1 << _s2hz))+ mov _s2hw, $arg3+ or $tmp, $arg3++ # Perform the call+ call func++This code is outright broken on Windows which assigns $arg1 to %rcx. This means+that the evaluation of the last argument clobbers the first argument.++To avoid this we use a rather awful hack: when producing code for a C call with+at least one non-trivial argument, we first evaluate all of the arguments into+local registers before moving them into their final calling-convention-defined+homes. This is performed by 'evalArgs'. Here we define "non-trivial" to be an+expression which might contain a MachOp since these are the only cases which+might clobber registers. Furthermore, we use a conservative approximation of+this condition (only looking at the top-level of CmmExprs) to avoid spending+too much effort trying to decide whether we want to take the fast path.++Note that this hack *also* applies to calls to out-of-line PrimTargets (which+are lowered via a C call), which will ultimately end up in+genForeignCall{32,64}.+-}++-- | See Note [Evaluate C-call arguments before placing in destination registers]+evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual])+evalArgs bid actuals+ | any mightContainMachOp actuals = do+ regs_blks <- mapM evalArg actuals+ return (concatOL $ map fst regs_blks, map snd regs_blks)+ | otherwise = return (nilOL, actuals)+ where+ mightContainMachOp (CmmReg _) = False+ mightContainMachOp (CmmRegOff _ _) = False+ mightContainMachOp (CmmLit _) = False+ mightContainMachOp _ = True++ evalArg :: CmmActual -> NatM (InstrBlock, CmmExpr)+ evalArg actual = do+ platform <- getPlatform+ lreg <- newLocalReg $ cmmExprType platform actual+ (instrs, bid1) <- stmtToInstrs bid $ CmmAssign (CmmLocal lreg) actual+ -- The above assignment shouldn't change the current block+ massert (isNothing bid1)+ return (instrs, CmmReg $ CmmLocal lreg)++ newLocalReg :: CmmType -> NatM LocalReg+ newLocalReg ty = LocalReg <$> getUniqueM <*> pure ty++-- Note [DIV/IDIV for bytes]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+-- IDIV reminder:+-- Size Dividend Divisor Quotient Remainder+-- byte %ax r/m8 %al %ah+-- word %dx:%ax r/m16 %ax %dx+-- dword %edx:%eax r/m32 %eax %edx+-- qword %rdx:%rax r/m64 %rax %rdx+--+-- We do a special case for the byte division because the current+-- codegen doesn't deal well with accessing %ah register (also,+-- accessing %ah in 64-bit mode is complicated because it cannot be an+-- operand of many instructions). So we just widen operands to 16 bits+-- and get the results from %al, %dl. This is not optimal, but a few+-- register moves are probably not a huge deal when doing division.+++-- | Generate C call to the given function in ghc-prim+genPrimCCall+ :: BlockId+ -> FastString+ -> [CmmFormal]+ -> [CmmActual]+ -> NatM InstrBlock+genPrimCCall bid lbl_txt dsts args = do+ config <- getConfig+ -- FIXME: we should use mkForeignLabel instead of mkCmmCodeLabel+ let lbl = mkCmmCodeLabel primUnitId lbl_txt+ addr <- cmmMakeDynamicReference config CallReference lbl+ let conv = ForeignConvention CCallConv [] [] CmmMayReturn+ genCCall bid addr conv dsts args++-- | Generate C call to the given function in libc+genLibCCall+ :: BlockId+ -> FastString+ -> [CmmFormal]+ -> [CmmActual]+ -> NatM InstrBlock+genLibCCall bid lbl_txt dsts args = do+ config <- getConfig+ -- Assume we can call these functions directly, and that they're not in a dynamic library.+ -- TODO: Why is this ok? Under linux this code will be in libm.so+ -- Is it because they're really implemented as a primitive instruction by the assembler?? -- BL 2009/12/31+ let lbl = mkForeignLabel lbl_txt Nothing ForeignLabelInThisPackage IsFunction+ addr <- cmmMakeDynamicReference config CallReference lbl+ let conv = ForeignConvention CCallConv [] [] CmmMayReturn+ genCCall bid addr conv dsts args++-- | Generate C call to the given function in the RTS+genRTSCCall+ :: BlockId+ -> FastString+ -> [CmmFormal]+ -> [CmmActual]+ -> NatM InstrBlock+genRTSCCall bid lbl_txt dsts args = do+ config <- getConfig+ -- Assume we can call these functions directly, and that they're not in a dynamic library.+ let lbl = mkForeignLabel lbl_txt Nothing ForeignLabelInThisPackage IsFunction+ addr <- cmmMakeDynamicReference config CallReference lbl+ let conv = ForeignConvention CCallConv [] [] CmmMayReturn+ genCCall bid addr conv dsts args++-- | Generate a real C call to the given address with the given convention+genCCall+ :: BlockId+ -> CmmExpr+ -> ForeignConvention+ -> [CmmFormal]+ -> [CmmActual]+ -> NatM InstrBlock+genCCall bid addr conv dest_regs args = do+ is32Bit <- is32BitPlatform+ (instrs0, args') <- evalArgs bid args+ instrs1 <- if is32Bit+ then genCCall32 addr conv dest_regs args'+ else genCCall64 addr conv dest_regs args'+ return (instrs0 `appOL` instrs1)++genCCall32 :: CmmExpr -- ^ address of the function to call+ -> ForeignConvention -- ^ calling convention+ -> [CmmFormal] -- ^ where to put the result+ -> [CmmActual] -- ^ arguments (of mixed type)+ -> NatM InstrBlock+genCCall32 addr conv dest_regs args = do+ config <- getConfig+ let platform = ncgPlatform config+ prom_args = map (maybePromoteCArg platform W32) args++ -- If the size is smaller than the word, we widen things (see maybePromoteCArg)+ arg_size_bytes :: CmmType -> Int+ arg_size_bytes ty = max (widthInBytes (typeWidth ty)) (widthInBytes (wordWidth platform))++ roundTo a x | x `mod` a == 0 = x+ | otherwise = x + a - (x `mod` a)++ push_arg :: CmmActual {-current argument-}+ -> NatM InstrBlock -- code++ push_arg arg -- we don't need the hints on x86+ | isWord64 arg_ty = do+ RegCode64 code r_hi r_lo <- iselExpr64 arg+ delta <- getDeltaNat+ setDeltaNat (delta - 8)+ return ( code `appOL`+ toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4),+ PUSH II32 (OpReg r_lo), DELTA (delta - 8),+ DELTA (delta-8)]+ )++ | isFloatType arg_ty = do+ (reg, code) <- getSomeReg arg+ delta <- getDeltaNat+ setDeltaNat (delta-size)+ return (code `appOL`+ toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp),+ DELTA (delta-size),+ let addr = AddrBaseIndex (EABaseReg esp)+ EAIndexNone+ (ImmInt 0)+ format = floatFormat (typeWidth arg_ty)+ in++ -- assume SSE2+ MOV format (OpReg reg) (OpAddr addr)++ ]+ )++ | otherwise = do+ -- Arguments can be smaller than 32-bit, but we still use @PUSH+ -- II32@ - the usual calling conventions expect integers to be+ -- 4-byte aligned.+ massert ((typeWidth arg_ty) <= W32)+ (operand, code) <- getOperand arg+ delta <- getDeltaNat+ setDeltaNat (delta-size)+ return (code `snocOL`+ PUSH II32 operand `snocOL`+ DELTA (delta-size))++ where+ arg_ty = cmmExprType platform arg+ size = arg_size_bytes arg_ty -- Byte size++ let+ -- Align stack to 16n for calls, assuming a starting stack+ -- alignment of 16n - word_size on procedure entry. Which we+ -- maintiain. See Note [Stack Alignment on X86] in rts/StgCRun.c.+ sizes = map (arg_size_bytes . cmmExprType platform) (reverse args)+ raw_arg_size = sum sizes + platformWordSizeInBytes platform+ arg_pad_size = (roundTo 16 $ raw_arg_size) - raw_arg_size+ tot_arg_size = raw_arg_size + arg_pad_size - platformWordSizeInBytes platform+++ delta0 <- getDeltaNat+ setDeltaNat (delta0 - arg_pad_size)++ push_codes <- mapM push_arg (reverse prom_args)+ delta <- getDeltaNat+ massert (delta == delta0 - tot_arg_size)++ -- deal with static vs dynamic call targets+ (callinsns,cconv) <-+ case addr of+ CmmLit (CmmLabel lbl)+ -> -- ToDo: stdcall arg sizes+ return (unitOL (CALL (Left fn_imm) []), conv)+ where fn_imm = ImmCLbl lbl+ _+ -> do { (dyn_r, dyn_c) <- getSomeReg addr+ ; massert (isWord32 (cmmExprType platform addr))+ ; return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }+ let push_code+ | arg_pad_size /= 0+ = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp),+ DELTA (delta0 - arg_pad_size)]+ `appOL` concatOL push_codes+ | otherwise+ = concatOL push_codes++ -- Deallocate parameters after call for ccall;+ -- but not for stdcall (callee does it)+ --+ -- We have to pop any stack padding we added+ -- even if we are doing stdcall, though (#5052)+ pop_size+ | ForeignConvention StdCallConv _ _ _ <- cconv = arg_pad_size+ | otherwise = tot_arg_size++ call = callinsns `appOL`+ toOL (+ (if pop_size==0 then [] else+ [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)])+ +++ [DELTA delta0]+ )+ setDeltaNat delta0++ let+ -- assign the results, if necessary+ assign_code [] = nilOL+ assign_code [dest]+ | isFloatType ty =+ -- we assume SSE2+ let tmp_amode = AddrBaseIndex (EABaseReg esp)+ EAIndexNone+ (ImmInt 0)+ fmt = floatFormat w+ in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp),+ DELTA (delta0 - b),+ X87Store fmt tmp_amode,+ -- X87Store only supported for the CDECL ABI+ -- NB: This code will need to be+ -- revisited once GHC does more work around+ -- SIGFPE f+ MOV fmt (OpAddr tmp_amode) (OpReg r_dest),+ ADD II32 (OpImm (ImmInt b)) (OpReg esp),+ DELTA delta0]+ | isWord64 ty = toOL [MOV II32 (OpReg eax) (OpReg r_dest),+ MOV II32 (OpReg edx) (OpReg r_dest_hi)]+ | otherwise = unitOL (MOV (intFormat w)+ (OpReg eax)+ (OpReg r_dest))+ where+ ty = localRegType dest+ w = typeWidth ty+ b = widthInBytes w+ r_dest_hi = getHiVRegFromLo r_dest+ r_dest = getLocalRegReg dest+ assign_code many = pprPanic "genForeignCall.assign_code - too many return values:" (ppr many)++ return (push_code `appOL`+ call `appOL`+ assign_code dest_regs)++genCCall64 :: CmmExpr -- ^ address of function to call+ -> ForeignConvention -- ^ calling convention+ -> [CmmFormal] -- ^ where to put the result+ -> [CmmActual] -- ^ arguments (of mixed type)+ -> NatM InstrBlock+genCCall64 addr conv dest_regs args = do+ platform <- getPlatform+ -- load up the register arguments+ let prom_args = map (maybePromoteCArg platform W32) args++ let load_args :: [CmmExpr]+ -> [Reg] -- int regs avail for args+ -> [Reg] -- FP regs avail for args+ -> InstrBlock -- code computing args+ -> InstrBlock -- code assigning args to ABI regs+ -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)+ -- no more regs to use+ load_args args [] [] code acode =+ return (args, [], [], code, acode)++ -- no more args to push+ load_args [] aregs fregs code acode =+ return ([], aregs, fregs, code, acode)++ load_args (arg : rest) aregs fregs code acode+ | isFloatType arg_rep = case fregs of+ [] -> push_this_arg+ (r:rs) -> do+ (code',acode') <- reg_this_arg r+ load_args rest aregs rs code' acode'+ | otherwise = case aregs of+ [] -> push_this_arg+ (r:rs) -> do+ (code',acode') <- reg_this_arg r+ load_args rest rs fregs code' acode'+ where++ -- put arg into the list of stack pushed args+ push_this_arg = do+ (args',ars,frs,code',acode')+ <- load_args rest aregs fregs code acode+ return (arg:args', ars, frs, code', acode')++ -- pass the arg into the given register+ reg_this_arg r+ -- "operand" args can be directly assigned into r+ | isOperand False arg = do+ arg_code <- getAnyReg arg+ return (code, (acode `appOL` arg_code r))+ -- The last non-operand arg can be directly assigned after its+ -- computation without going into a temporary register+ | all (isOperand False) rest = do+ arg_code <- getAnyReg arg+ return (code `appOL` arg_code r,acode)++ -- other args need to be computed beforehand to avoid clobbering+ -- previously assigned registers used to pass parameters (see+ -- #11792, #12614). They are assigned into temporary registers+ -- and get assigned to proper call ABI registers after they all+ -- have been computed.+ | otherwise = do+ arg_code <- getAnyReg arg+ tmp <- getNewRegNat arg_fmt+ let+ code' = code `appOL` arg_code tmp+ acode' = acode `snocOL` reg2reg arg_fmt tmp r+ return (code',acode')++ arg_rep = cmmExprType platform arg+ arg_fmt = cmmTypeFormat arg_rep++ load_args_win :: [CmmExpr]+ -> [Reg] -- used int regs+ -> [Reg] -- used FP regs+ -> [(Reg, Reg)] -- (int, FP) regs avail for args+ -> InstrBlock+ -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)+ load_args_win args usedInt usedFP [] code+ = return (args, usedInt, usedFP, code, nilOL)+ -- no more regs to use+ load_args_win [] usedInt usedFP _ code+ = return ([], usedInt, usedFP, code, nilOL)+ -- no more args to push+ load_args_win (arg : rest) usedInt usedFP+ ((ireg, freg) : regs) code+ | isFloatType arg_rep = do+ arg_code <- getAnyReg arg+ load_args_win rest (ireg : usedInt) (freg : usedFP) regs+ (code `appOL`+ arg_code freg `snocOL`+ -- If we are calling a varargs function+ -- then we need to define ireg as well+ -- as freg+ MOV II64 (OpReg freg) (OpReg ireg))+ | otherwise = do+ arg_code <- getAnyReg arg+ load_args_win rest (ireg : usedInt) usedFP regs+ (code `appOL` arg_code ireg)+ where+ arg_rep = cmmExprType platform arg++ arg_size = 8 -- always, at the mo++ push_args [] code = return code+ push_args (arg:rest) code+ | isFloatType arg_rep = do+ (arg_reg, arg_code) <- getSomeReg arg+ delta <- getDeltaNat+ setDeltaNat (delta-arg_size)+ let code' = code `appOL` arg_code `appOL` toOL [+ SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_size)) (OpReg rsp),+ DELTA (delta-arg_size),+ MOV (floatFormat width) (OpReg arg_reg) (OpAddr (spRel platform 0))]+ push_args rest code'++ | otherwise = do+ -- Arguments can be smaller than 64-bit, but we still use @PUSH+ -- II64@ - the usual calling conventions expect integers to be+ -- 8-byte aligned.+ massert (width <= W64)+ (arg_op, arg_code) <- getOperand arg+ delta <- getDeltaNat+ setDeltaNat (delta-arg_size)+ let code' = code `appOL` arg_code `appOL` toOL [+ PUSH II64 arg_op,+ DELTA (delta-arg_size)]+ push_args rest code'+ where+ arg_rep = cmmExprType platform arg+ width = typeWidth arg_rep++ leaveStackSpace n = do+ delta <- getDeltaNat+ setDeltaNat (delta - n * arg_size)+ return $ toOL [+ SUB II64 (OpImm (ImmInt (n * platformWordSizeInBytes platform))) (OpReg rsp),+ DELTA (delta - n * arg_size)]++ (stack_args, int_regs_used, fp_regs_used, load_args_code, assign_args_code)+ <-+ if platformOS platform == OSMinGW32+ then load_args_win prom_args [] [] (allArgRegs platform) nilOL+ else do+ (stack_args, aregs, fregs, load_args_code, assign_args_code)+ <- load_args prom_args (allIntArgRegs platform)+ (allFPArgRegs platform)+ nilOL nilOL+ let used_regs rs as = reverse (drop (length rs) (reverse as))+ fregs_used = used_regs fregs (allFPArgRegs platform)+ aregs_used = used_regs aregs (allIntArgRegs platform)+ return (stack_args, aregs_used, fregs_used, load_args_code+ , assign_args_code)++ let+ arg_regs_used = int_regs_used ++ fp_regs_used+ arg_regs = [eax] ++ arg_regs_used+ -- for annotating the call instruction with+ sse_regs = length fp_regs_used+ arg_stack_slots = if platformOS platform == OSMinGW32+ then length stack_args + length (allArgRegs platform)+ else length stack_args+ tot_arg_size = arg_size * arg_stack_slots+++ -- Align stack to 16n for calls, assuming a starting stack+ -- alignment of 16n - word_size on procedure entry. Which we+ -- maintain. See Note [Stack Alignment on X86] in rts/StgCRun.c+ let word_size = platformWordSizeInBytes platform+ (real_size, adjust_rsp) <-+ if (tot_arg_size + word_size) `rem` 16 == 0+ then return (tot_arg_size, nilOL)+ else do -- we need to adjust...+ delta <- getDeltaNat+ setDeltaNat (delta - word_size)+ return (tot_arg_size + word_size, toOL [+ SUB II64 (OpImm (ImmInt word_size)) (OpReg rsp),+ DELTA (delta - word_size) ])++ -- push the stack args, right to left+ push_code <- push_args (reverse stack_args) nilOL+ -- On Win64, we also have to leave stack space for the arguments+ -- that we are passing in registers+ lss_code <- if platformOS platform == OSMinGW32+ then leaveStackSpace (length (allArgRegs platform))+ else return nilOL+ delta <- getDeltaNat++ -- deal with static vs dynamic call targets+ (callinsns,_cconv) <- case addr of+ CmmLit (CmmLabel lbl) ->+ -- ToDo: stdcall arg sizes+ return (unitOL (CALL (Left (ImmCLbl lbl)) arg_regs), conv)+ _ -> do+ (dyn_r, dyn_c) <- getSomeReg addr+ return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv)++ let+ -- The x86_64 ABI requires us to set %al to the number of SSE2+ -- registers that contain arguments, if the called routine+ -- is a varargs function. We don't know whether it's a+ -- varargs function or not, so we have to assume it is.+ --+ -- It's not safe to omit this assignment, even if the number+ -- of SSE2 regs in use is zero. If %al is larger than 8+ -- on entry to a varargs function, seg faults ensue.+ assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax))++ let call = callinsns `appOL`+ toOL (+ -- Deallocate parameters after call for ccall;+ -- stdcall has callee do it, but is not supported on+ -- x86_64 target (see #3336)+ (if real_size==0 then [] else+ [ADD (intFormat (platformWordWidth platform)) (OpImm (ImmInt real_size)) (OpReg esp)])+ +++ [DELTA (delta + real_size)]+ )+ setDeltaNat (delta + real_size)++ let+ -- assign the results, if necessary+ assign_code [] = nilOL+ assign_code [dest] =+ case typeWidth rep of+ W32 | isFloatType rep -> unitOL (MOV (floatFormat W32)+ (OpReg xmm0)+ (OpReg r_dest))+ W64 | isFloatType rep -> unitOL (MOV (floatFormat W64)+ (OpReg xmm0)+ (OpReg r_dest))+ _ -> unitOL (MOV (cmmTypeFormat rep) (OpReg rax) (OpReg r_dest))+ where+ rep = localRegType dest+ r_dest = getRegisterReg platform (CmmLocal dest)+ assign_code _many = panic "genForeignCall.assign_code many"++ return (adjust_rsp `appOL`+ push_code `appOL`+ load_args_code `appOL`+ assign_args_code `appOL`+ lss_code `appOL`+ assign_eax sse_regs `appOL`+ call `appOL`+ assign_code dest_regs)+++maybePromoteCArg :: Platform -> Width -> CmmExpr -> CmmExpr+maybePromoteCArg platform wto arg+ | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg]+ | otherwise = arg+ where+ wfrom = cmmExprWidth platform arg++-- -----------------------------------------------------------------------------+-- Generating a table-branch++genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock++genSwitch expr targets = do+ config <- getConfig+ let platform = ncgPlatform config+ -- We widen to a native-width register because we cannot use arbitry sizes+ -- in x86 addressing modes.+ exprWidened = CmmMachOp+ (MO_UU_Conv (cmmExprWidth platform expr)+ (platformWordWidth platform))+ [expr]+ indexExpr = cmmOffset platform exprWidened offset+ if ncgPIC config+ then do+ (reg,e_code) <- getNonClobberedReg indexExpr+ -- getNonClobberedReg because it needs to survive across t_code+ lbl <- getNewLabelNat+ let is32bit = target32Bit platform+ os = platformOS platform+ -- Might want to use .rodata.<function we're in> instead, but as+ -- long as it's something unique it'll work out since the+ -- references to the jump table are in the appropriate section.+ rosection = case os of+ -- on Mac OS X/x86_64, put the jump table in the text section to+ -- work around a limitation of the linker.+ -- ld64 is unable to handle the relocations for+ -- .quad L1 - L0+ -- if L0 is not preceded by a non-anonymous label in its section.+ OSDarwin | not is32bit -> Section Text lbl+ _ -> Section ReadOnlyData lbl+ dynRef <- cmmMakeDynamicReference config DataReference lbl+ (tableReg,t_code) <- getSomeReg $ dynRef+ let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)+ (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))++ offsetReg <- getNewRegNat (intFormat (platformWordWidth platform))+ return $ if is32bit || os == OSDarwin+ then e_code `appOL` t_code `appOL` toOL [+ ADD (intFormat (platformWordWidth platform)) op (OpReg tableReg),+ JMP_TBL (OpReg tableReg) ids rosection lbl+ ]+ else -- HACK: On x86_64 binutils<2.17 is only able to generate+ -- PC32 relocations, hence we only get 32-bit offsets in+ -- the jump table. As these offsets are always negative+ -- we need to properly sign extend them to 64-bit. This+ -- hack should be removed in conjunction with the hack in+ -- PprMach.hs/pprDataItem once binutils 2.17 is standard.+ e_code `appOL` t_code `appOL` toOL [+ MOVSxL II32 op (OpReg offsetReg),+ ADD (intFormat (platformWordWidth platform))+ (OpReg offsetReg)+ (OpReg tableReg),+ JMP_TBL (OpReg tableReg) ids rosection lbl+ ]+ else do+ (reg,e_code) <- getSomeReg indexExpr+ lbl <- getNewLabelNat+ let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl lbl))+ code = e_code `appOL` toOL [+ JMP_TBL op ids (Section ReadOnlyData lbl) lbl+ ]+ return code+ where+ (offset, blockIds) = switchTargetsToTable targets+ ids = map (fmap DestBlockId) blockIds++generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr)+generateJumpTableForInstr config (JMP_TBL _ ids section lbl)+ = let getBlockId (DestBlockId id) = id+ getBlockId _ = panic "Non-Label target in Jump Table"+ blockIds = map (fmap getBlockId) ids+ in Just (createJumpTable config blockIds section lbl)+generateJumpTableForInstr _ _ = Nothing++createJumpTable :: NCGConfig -> [Maybe BlockId] -> Section -> CLabel+ -> GenCmmDecl (Alignment, RawCmmStatics) h g+createJumpTable config ids section lbl+ = let jumpTable+ | ncgPIC config =+ let ww = ncgWordWidth config+ jumpTableEntryRel Nothing+ = CmmStaticLit (CmmInt 0 ww)+ jumpTableEntryRel (Just blockid)+ = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 ww)+ where blockLabel = blockLbl blockid+ in map jumpTableEntryRel ids+ | otherwise = map (jumpTableEntry config) ids+ in CmmData section (mkAlignment 1, CmmStaticsRaw lbl jumpTable)++extractUnwindPoints :: [Instr] -> [UnwindPoint]+extractUnwindPoints instrs =+ [ UnwindPoint lbl unwinds | UNWIND lbl unwinds <- instrs]++-- -----------------------------------------------------------------------------+-- 'condIntReg' and 'condFltReg': condition codes into registers++-- Turn those condition codes into integers now (when they appear on+-- the right hand side of an assignment).+--+-- (If applicable) Do not fill the delay slots here; you will confuse the+-- register allocator.++condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register++condIntReg cond x y = do+ CondCode _ cond cond_code <- condIntCode cond x y+ tmp <- getNewRegNat II8+ let+ code dst = cond_code `appOL` toOL [+ SETCC cond (OpReg tmp),+ MOVZxL II8 (OpReg tmp) (OpReg dst)+ ]+ return (Any II32 code)+++-- Note [SSE Parity Checks]+-- ~~~~~~~~~~~~~~~~~~~~~~~~+-- We have to worry about unordered operands (eg. comparisons+-- against NaN). If the operands are unordered, the comparison+-- sets the parity flag, carry flag and zero flag.+-- All comparisons are supposed to return false for unordered+-- operands except for !=, which returns true.+--+-- Optimisation: we don't have to test the parity flag if we+-- know the test has already excluded the unordered case: eg >+-- and >= test for a zero carry flag, which can only occur for+-- ordered operands.+--+-- By reversing comparisons we can avoid testing the parity+-- for < and <= as well. If any of the arguments is an NaN we+-- return false either way. If both arguments are valid then+-- x <= y <-> y >= x holds. So it's safe to swap these.+--+-- We invert the condition inside getRegister'and getCondCode+-- which should cover all invertable cases.+-- All other functions translating FP comparisons to assembly+-- use these to two generate the comparison code.+--+-- As an example consider a simple check:+--+-- func :: Float -> Float -> Int+-- func x y = if x < y then 1 else 0+--+-- Which in Cmm gives the floating point comparison.+--+-- if (%MO_F_Lt_W32(F1, F2)) goto c2gg; else goto c2gf;+--+-- We used to compile this to an assembly code block like this:+-- _c2gh:+-- ucomiss %xmm2,%xmm1+-- jp _c2gf+-- jb _c2gg+-- jmp _c2gf+--+-- Where we have to introduce an explicit+-- check for unordered results (using jmp parity):+--+-- We can avoid this by exchanging the arguments and inverting the direction+-- of the comparison. This results in the sequence of:+--+-- ucomiss %xmm1,%xmm2+-- ja _c2g2+-- jmp _c2g1+--+-- Removing the jump reduces the pressure on the branch predidiction system+-- and plays better with the uOP cache.++condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register+condFltReg is32Bit cond x y = condFltReg_sse2+ where+++ condFltReg_sse2 = do+ CondCode _ cond cond_code <- condFltCode cond x y+ tmp1 <- getNewRegNat (archWordFormat is32Bit)+ tmp2 <- getNewRegNat (archWordFormat is32Bit)+ let -- See Note [SSE Parity Checks]+ code dst =+ cond_code `appOL`+ (case cond of+ NE -> or_unordered dst+ GU -> plain_test dst+ GEU -> plain_test dst+ -- Use ASSERT so we don't break releases if these creep in.+ LTT -> assertPpr False (ppr "Should have been turned into >") $+ and_ordered dst+ LE -> assertPpr False (ppr "Should have been turned into >=") $+ and_ordered dst+ _ -> and_ordered dst)++ plain_test dst = toOL [+ SETCC cond (OpReg tmp1),+ MOVZxL II8 (OpReg tmp1) (OpReg dst)+ ]+ or_unordered dst = toOL [+ SETCC cond (OpReg tmp1),+ SETCC PARITY (OpReg tmp2),+ OR II8 (OpReg tmp1) (OpReg tmp2),+ MOVZxL II8 (OpReg tmp2) (OpReg dst)+ ]+ and_ordered dst = toOL [+ SETCC cond (OpReg tmp1),+ SETCC NOTPARITY (OpReg tmp2),+ AND II8 (OpReg tmp1) (OpReg tmp2),+ MOVZxL II8 (OpReg tmp2) (OpReg dst)+ ]+ return (Any II32 code)+++-- -----------------------------------------------------------------------------+-- 'trivial*Code': deal with trivial instructions++-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',+-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.+-- Only look for constants on the right hand side, because that's+-- where the generic optimizer will have put them.++-- Similarly, for unary instructions, we don't have to worry about+-- matching an StInt as the argument, because genericOpt will already+-- have handled the constant-folding.+++{-+The Rules of the Game are:++* You cannot assume anything about the destination register dst;+ it may be anything, including a fixed reg.++* You may compute an operand into a fixed reg, but you may not+ subsequently change the contents of that fixed reg. If you+ want to do so, first copy the value either to a temporary+ or into dst. You are free to modify dst even if it happens+ to be a fixed reg -- that's not your problem.++* You cannot assume that a fixed reg will stay live over an+ arbitrary computation. The same applies to the dst reg.++* Temporary regs obtained from getNewRegNat are distinct from+ each other and from all other regs, and stay live over+ arbitrary computations.++--------------------++SDM's version of The Rules:++* If getRegister returns Any, that means it can generate correct+ code which places the result in any register, period. Even if that+ register happens to be read during the computation.++ Corollary #1: this means that if you are generating code for an+ operation with two arbitrary operands, you cannot assign the result+ of the first operand into the destination register before computing+ the second operand. The second operand might require the old value+ of the destination register.++ Corollary #2: A function might be able to generate more efficient+ code if it knows the destination register is a new temporary (and+ therefore not read by any of the sub-computations).++* If getRegister returns Any, then the code it generates may modify only:+ (a) fresh temporaries+ (b) the destination register+ (c) known registers (eg. %ecx is used by shifts)+ In particular, it may *not* modify global registers, unless the global+ register happens to be the destination register.+-}++trivialCode :: Width -> (Operand -> Operand -> Instr)+ -> Maybe (Operand -> Operand -> Instr)+ -> CmmExpr -> CmmExpr -> NatM Register+trivialCode width instr m a b+ = do is32Bit <- is32BitPlatform+ trivialCode' is32Bit width instr m a b++trivialCode' :: Bool -> Width -> (Operand -> Operand -> Instr)+ -> Maybe (Operand -> Operand -> Instr)+ -> CmmExpr -> CmmExpr -> NatM Register+trivialCode' is32Bit width _ (Just revinstr) (CmmLit lit_a) b+ | is32BitLit is32Bit lit_a = do+ b_code <- getAnyReg b+ let+ code dst+ = b_code dst `snocOL`+ revinstr (OpImm (litToImm lit_a)) (OpReg dst)+ return (Any (intFormat width) code)++trivialCode' _ width instr _ a b+ = genTrivialCode (intFormat width) instr a b++-- This is re-used for floating pt instructions too.+genTrivialCode :: Format -> (Operand -> Operand -> Instr)+ -> CmmExpr -> CmmExpr -> NatM Register+genTrivialCode rep instr a b = do+ (b_op, b_code) <- getNonClobberedOperand b+ a_code <- getAnyReg a+ tmp <- getNewRegNat rep+ let+ -- We want the value of b to stay alive across the computation of a.+ -- But, we want to calculate a straight into the destination register,+ -- because the instruction only has two operands (dst := dst `op` src).+ -- The troublesome case is when the result of b is in the same register+ -- as the destination reg. In this case, we have to save b in a+ -- new temporary across the computation of a.+ code dst+ | dst `regClashesWithOp` b_op =+ b_code `appOL`+ unitOL (MOV rep b_op (OpReg tmp)) `appOL`+ a_code dst `snocOL`+ instr (OpReg tmp) (OpReg dst)+ | otherwise =+ b_code `appOL`+ a_code dst `snocOL`+ instr b_op (OpReg dst)+ return (Any rep code)++regClashesWithOp :: Reg -> Operand -> Bool+reg `regClashesWithOp` OpReg reg2 = reg == reg2+reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode)+_ `regClashesWithOp` _ = False++-----------++trivialUCode :: Format -> (Operand -> Instr)+ -> CmmExpr -> NatM Register+trivialUCode rep instr x = do+ x_code <- getAnyReg x+ let+ code dst =+ x_code dst `snocOL`+ instr (OpReg dst)+ return (Any rep code)++-----------+++trivialFCode_sse2 :: Width -> (Format -> Operand -> Operand -> Instr)+ -> CmmExpr -> CmmExpr -> NatM Register+trivialFCode_sse2 pk instr x y+ = genTrivialCode format (instr format) x y+ where format = floatFormat pk+++--------------------------------------------------------------------------------+coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register+coerceInt2FP from to x = coerce_sse2+ where++ coerce_sse2 = do+ (x_op, x_code) <- getOperand x -- ToDo: could be a safe operand+ let+ opc = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD+ n -> panic $ "coerceInt2FP.sse: unhandled width ("+ ++ show n ++ ")"+ code dst = x_code `snocOL` opc (intFormat from) x_op dst+ return (Any (floatFormat to) code)+ -- works even if the destination rep is <II32++--------------------------------------------------------------------------------+coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register+coerceFP2Int from to x = coerceFP2Int_sse2+ where+ coerceFP2Int_sse2 = do+ (x_op, x_code) <- getOperand x -- ToDo: could be a safe operand+ let+ opc = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ;+ n -> panic $ "coerceFP2Init.sse: unhandled width ("+ ++ show n ++ ")"+ code dst = x_code `snocOL` opc (intFormat to) x_op dst+ return (Any (intFormat to) code)+ -- works even if the destination rep is <II32+++--------------------------------------------------------------------------------+coerceFP2FP :: Width -> CmmExpr -> NatM Register+coerceFP2FP to x = do+ (x_reg, x_code) <- getSomeReg x+ let+ opc = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD;+ n -> panic $ "coerceFP2FP: unhandled width ("+ ++ show n ++ ")"+ code dst = x_code `snocOL` opc x_reg dst+ return (Any ( floatFormat to) code)++--------------------------------------------------------------------------------++sse2NegCode :: Width -> CmmExpr -> NatM Register+sse2NegCode w x = do+ let fmt = floatFormat w+ x_code <- getAnyReg x+ -- This is how gcc does it, so it can't be that bad:+ let+ const = case fmt of+ FF32 -> CmmInt 0x80000000 W32+ FF64 -> CmmInt 0x8000000000000000 W64+ x@II8 -> wrongFmt x+ x@II16 -> wrongFmt x+ x@II32 -> wrongFmt x+ x@II64 -> wrongFmt x++ where+ wrongFmt x = panic $ "sse2NegCode: " ++ show x+ Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const+ tmp <- getNewRegNat fmt+ let+ code dst = x_code dst `appOL` amode_code `appOL` toOL [+ MOV fmt (OpAddr amode) (OpReg tmp),+ XOR fmt (OpReg tmp) (OpReg dst)+ ]+ --+ return (Any fmt code)++isVecExpr :: CmmExpr -> Bool+isVecExpr (CmmMachOp (MO_V_Insert {}) _) = True+isVecExpr (CmmMachOp (MO_V_Extract {}) _) = True+isVecExpr (CmmMachOp (MO_V_Add {}) _) = True+isVecExpr (CmmMachOp (MO_V_Sub {}) _) = True+isVecExpr (CmmMachOp (MO_V_Mul {}) _) = True+isVecExpr (CmmMachOp (MO_VS_Quot {}) _) = True+isVecExpr (CmmMachOp (MO_VS_Rem {}) _) = True+isVecExpr (CmmMachOp (MO_VS_Neg {}) _) = True+isVecExpr (CmmMachOp (MO_VF_Insert {}) _) = True+isVecExpr (CmmMachOp (MO_VF_Extract {}) _) = True+isVecExpr (CmmMachOp (MO_VF_Add {}) _) = True+isVecExpr (CmmMachOp (MO_VF_Sub {}) _) = True+isVecExpr (CmmMachOp (MO_VF_Mul {}) _) = True+isVecExpr (CmmMachOp (MO_VF_Quot {}) _) = True+isVecExpr (CmmMachOp (MO_VF_Neg {}) _) = True+isVecExpr (CmmMachOp _ [e]) = isVecExpr e+isVecExpr _ = False++needLlvm :: NatM a+needLlvm =+ sorry $ unlines ["The native code generator does not support vector"+ ,"instructions. Please use -fllvm."]++-- | This works on the invariant that all jumps in the given blocks are required.+-- Starting from there we try to make a few more jumps redundant by reordering+-- them.+-- We depend on the information in the CFG to do so so without a given CFG+-- we do nothing.+invertCondBranches :: Maybe CFG -- ^ CFG if present+ -> LabelMap a -- ^ Blocks with info tables+ -> [NatBasicBlock Instr] -- ^ List of basic blocks+ -> [NatBasicBlock Instr]+invertCondBranches Nothing _ bs = bs+invertCondBranches (Just cfg) keep bs =+ invert bs+ where+ invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr]+ invert ((BasicBlock lbl1 ins@(_:_:_xs)):b2@(BasicBlock lbl2 _):bs)+ | --pprTrace "Block" (ppr lbl1) True,+ (jmp1,jmp2) <- last2 ins+ , JXX cond1 target1 <- jmp1+ , target1 == lbl2+ --, pprTrace "CutChance" (ppr b1) True+ , JXX ALWAYS target2 <- jmp2+ -- We have enough information to check if we can perform the inversion+ -- TODO: We could also check for the last asm instruction which sets+ -- status flags instead. Which I suspect is worse in terms of compiler+ -- performance, but might be applicable to more cases+ , Just edgeInfo1 <- getEdgeInfo lbl1 target1 cfg+ , Just edgeInfo2 <- getEdgeInfo lbl1 target2 cfg+ -- Both jumps come from the same cmm statement+ , transitionSource edgeInfo1 == transitionSource edgeInfo2+ , CmmSource {trans_cmmNode = cmmCondBranch} <- transitionSource edgeInfo1++ --Int comparisons are invertable+ , CmmCondBranch (CmmMachOp op _args) _ _ _ <- cmmCondBranch+ , Just _ <- maybeIntComparison op+ , Just invCond <- maybeInvertCond cond1++ --Swap the last two jumps, invert the conditional jumps condition.+ = let jumps =+ case () of+ -- We are free the eliminate the jmp. So we do so.+ _ | not (mapMember target1 keep)+ -> [JXX invCond target2]+ -- If the conditional target is unlikely we put the other+ -- target at the front.+ | edgeWeight edgeInfo2 > edgeWeight edgeInfo1+ -> [JXX invCond target2, JXX ALWAYS target1]+ -- Keep things as-is otherwise+ | otherwise+ -> [jmp1, jmp2]+ in --pprTrace "Cutable" (ppr [jmp1,jmp2] <+> text "=>" <+> ppr jumps) $+ (BasicBlock lbl1+ (dropTail 2 ins ++ jumps))+ : invert (b2:bs)+ invert (b:bs) = b : invert bs+ invert [] = []++genAtomicRMW+ :: BlockId+ -> Width+ -> AtomicMachOp+ -> LocalReg+ -> CmmExpr+ -> CmmExpr+ -> NatM (InstrBlock, Maybe BlockId)+genAtomicRMW bid width amop dst addr n = do+ Amode amode addr_code <-+ if amop `elem` [AMO_Add, AMO_Sub]+ then getAmode addr+ else getSimpleAmode addr -- See genForeignCall for MO_Cmpxchg+ arg <- getNewRegNat format+ arg_code <- getAnyReg n+ platform <- ncgPlatform <$> getConfig++ let dst_r = getRegisterReg platform (CmmLocal dst)+ (code, lbl) <- op_code dst_r arg amode+ return (addr_code `appOL` arg_code arg `appOL` code, Just lbl)+ where+ -- Code for the operation+ op_code :: Reg -- Destination reg+ -> Reg -- Register containing argument+ -> AddrMode -- Address of location to mutate+ -> NatM (OrdList Instr,BlockId) -- TODO: Return Maybe BlockId+ op_code dst_r arg amode = case amop of+ -- In the common case where dst_r is a virtual register the+ -- final move should go away, because it's the last use of arg+ -- and the first use of dst_r.+ AMO_Add -> return $ (toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode))+ , MOV format (OpReg arg) (OpReg dst_r)+ ], bid)+ AMO_Sub -> return $ (toOL [ NEGI format (OpReg arg)+ , LOCK (XADD format (OpReg arg) (OpAddr amode))+ , MOV format (OpReg arg) (OpReg dst_r)+ ], bid)+ -- In these cases we need a new block id, and have to return it so+ -- that later instruction selection can reference it.+ AMO_And -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst)+ AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst+ , NOT format dst+ ])+ AMO_Or -> cmpxchg_code (\ src dst -> unitOL $ OR format src dst)+ AMO_Xor -> cmpxchg_code (\ src dst -> unitOL $ XOR format src dst)+ where+ -- Simulate operation that lacks a dedicated instruction using+ -- cmpxchg.+ cmpxchg_code :: (Operand -> Operand -> OrdList Instr)+ -> NatM (OrdList Instr, BlockId)+ cmpxchg_code instrs = do+ lbl1 <- getBlockIdNat+ lbl2 <- getBlockIdNat+ tmp <- getNewRegNat format++ --Record inserted blocks+ -- We turn A -> B into A -> A' -> A'' -> B+ -- with a self loop on A'.+ addImmediateSuccessorNat bid lbl1+ addImmediateSuccessorNat lbl1 lbl2+ updateCfgNat (addWeightEdge lbl1 lbl1 0)++ return $ (toOL+ [ MOV format (OpAddr amode) (OpReg eax)+ , JXX ALWAYS lbl1+ , NEWBLOCK lbl1+ -- Keep old value so we can return it:+ , MOV format (OpReg eax) (OpReg dst_r)+ , MOV format (OpReg eax) (OpReg tmp)+ ]+ `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL+ [ LOCK (CMPXCHG format (OpReg tmp) (OpAddr amode))+ , JXX NE lbl1+ -- See Note [Introducing cfg edges inside basic blocks]+ -- why this basic block is required.+ , JXX ALWAYS lbl2+ , NEWBLOCK lbl2+ ],+ lbl2)+ format = intFormat width++-- | Count trailing zeroes+genCtz :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM (InstrBlock, Maybe BlockId)+genCtz bid width dst src = do+ is32Bit <- is32BitPlatform+ if is32Bit && width == W64+ then genCtz64_32 bid dst src+ else (,Nothing) <$> genCtzGeneric width dst src++-- | Count trailing zeroes+--+-- 64-bit width on 32-bit architecture+genCtz64_32+ :: BlockId+ -> LocalReg+ -> CmmExpr+ -> NatM (InstrBlock, Maybe BlockId)+genCtz64_32 bid dst src = do+ RegCode64 vcode rhi rlo <- iselExpr64 src+ let dst_r = getLocalRegReg dst+ lbl1 <- getBlockIdNat+ lbl2 <- getBlockIdNat+ tmp_r <- getNewRegNat II64++ -- New CFG Edges:+ -- bid -> lbl2+ -- bid -> lbl1 -> lbl2+ -- We also changes edges originating at bid to start at lbl2 instead.+ weights <- getCfgWeights+ updateCfgNat (addWeightEdge bid lbl1 110 .+ addWeightEdge lbl1 lbl2 110 .+ addImmediateSuccessor weights bid lbl2)++ -- The following instruction sequence corresponds to the pseudo-code+ --+ -- if (src) {+ -- dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32);+ -- } else {+ -- dst = 64;+ -- }+ let instrs = vcode `appOL` toOL+ ([ MOV II32 (OpReg rhi) (OpReg tmp_r)+ , OR II32 (OpReg rlo) (OpReg tmp_r)+ , MOV II32 (OpImm (ImmInt 64)) (OpReg dst_r)+ , JXX EQQ lbl2+ , JXX ALWAYS lbl1++ , NEWBLOCK lbl1+ , BSF II32 (OpReg rhi) dst_r+ , ADD II32 (OpImm (ImmInt 32)) (OpReg dst_r)+ , BSF II32 (OpReg rlo) tmp_r+ , CMOV NE II32 (OpReg tmp_r) dst_r+ , JXX ALWAYS lbl2++ , NEWBLOCK lbl2+ ])+ return (instrs, Just lbl2)++-- | Count trailing zeroes+--+-- Generic case (width <= word size)+genCtzGeneric :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock+genCtzGeneric width dst src = do+ code_src <- getAnyReg src+ config <- getConfig+ let bw = widthInBits width+ let dst_r = getLocalRegReg dst+ if ncgBmiVersion config >= Just BMI2+ then do+ src_r <- getNewRegNat (intFormat width)+ let instrs = appOL (code_src src_r) $ case width of+ W8 -> toOL+ [ OR II32 (OpImm (ImmInteger 0xFFFFFF00)) (OpReg src_r)+ , TZCNT II32 (OpReg src_r) dst_r+ ]+ W16 -> toOL+ [ TZCNT II16 (OpReg src_r) dst_r+ , MOVZxL II16 (OpReg dst_r) (OpReg dst_r)+ ]+ _ -> unitOL $ TZCNT (intFormat width) (OpReg src_r) dst_r+ return instrs+ else do+ -- The following insn sequence makes sure 'ctz 0' has a defined value.+ -- starting with Haswell, one could use the TZCNT insn instead.+ let format = if width == W8 then II16 else intFormat width+ src_r <- getNewRegNat format+ tmp_r <- getNewRegNat format+ let instrs = code_src src_r `appOL` toOL+ ([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] +++ [ BSF format (OpReg src_r) tmp_r+ , MOV II32 (OpImm (ImmInt bw)) (OpReg dst_r)+ , CMOV NE format (OpReg tmp_r) dst_r+ ]) -- NB: We don't need to zero-extend the result for the+ -- W8/W16 cases because the 'MOV' insn already+ -- took care of implicitly clearing the upper bits+ return instrs++++-- | Copy memory+--+-- Unroll memcpy calls if the number of bytes to copy isn't too large (cf+-- ncgInlineThresholdMemcpy). Otherwise, call C's memcpy.+genMemCpy+ :: BlockId+ -> Int+ -> CmmExpr+ -> CmmExpr+ -> CmmExpr+ -> NatM InstrBlock+genMemCpy bid align dst src arg_n = do++ let libc_memcpy = genLibCCall bid (fsLit "memcpy") [] [dst,src,arg_n]++ case arg_n of+ CmmLit (CmmInt n _) -> do+ -- try to inline it+ mcode <- genMemCpyInlineMaybe align dst src n+ -- if it didn't inline, call the C function+ case mcode of+ Nothing -> libc_memcpy+ Just c -> pure c++ -- not a literal size argument: call the C function+ _ -> libc_memcpy++++genMemCpyInlineMaybe+ :: Int+ -> CmmExpr+ -> CmmExpr+ -> Integer+ -> NatM (Maybe InstrBlock)+genMemCpyInlineMaybe align dst src n = do+ config <- getConfig+ let+ platform = ncgPlatform config+ maxAlignment = wordAlignment platform+ -- only machine word wide MOVs are supported+ effectiveAlignment = min (alignmentOf align) maxAlignment+ format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment+++ -- The size of each move, in bytes.+ let sizeBytes :: Integer+ sizeBytes = fromIntegral (formatInBytes format)++ -- The number of instructions we will generate (approx). We need 2+ -- instructions per move.+ let insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes)++ go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr+ go dst src tmp i+ | i >= sizeBytes =+ unitOL (MOV format (OpAddr src_addr) (OpReg tmp)) `appOL`+ unitOL (MOV format (OpReg tmp) (OpAddr dst_addr)) `appOL`+ go dst src tmp (i - sizeBytes)+ -- Deal with remaining bytes.+ | i >= 4 = -- Will never happen on 32-bit+ unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL`+ unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL`+ go dst src tmp (i - 4)+ | i >= 2 =+ unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL`+ unitOL (MOV II16 (OpReg tmp) (OpAddr dst_addr)) `appOL`+ go dst src tmp (i - 2)+ | i >= 1 =+ unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL`+ unitOL (MOV II8 (OpReg tmp) (OpAddr dst_addr)) `appOL`+ go dst src tmp (i - 1)+ | otherwise = nilOL+ where+ src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone+ (ImmInteger (n - i))++ dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone+ (ImmInteger (n - i))++ if insns > fromIntegral (ncgInlineThresholdMemcpy config)+ then pure Nothing+ else do+ code_dst <- getAnyReg dst+ dst_r <- getNewRegNat format+ code_src <- getAnyReg src+ src_r <- getNewRegNat format+ tmp_r <- getNewRegNat format+ pure $ Just $ code_dst dst_r `appOL` code_src src_r `appOL`+ go dst_r src_r tmp_r (fromInteger n)++-- | Set memory to the given byte+--+-- Unroll memset calls if the number of bytes to copy isn't too large (cf+-- ncgInlineThresholdMemset). Otherwise, call C's memset.+genMemSet+ :: BlockId+ -> Int+ -> CmmExpr+ -> CmmExpr+ -> CmmExpr+ -> NatM InstrBlock+genMemSet bid align dst arg_c arg_n = do++ let libc_memset = genLibCCall bid (fsLit "memset") [] [dst,arg_c,arg_n]++ case (arg_c,arg_n) of+ (CmmLit (CmmInt c _), CmmLit (CmmInt n _)) -> do+ -- try to inline it+ mcode <- genMemSetInlineMaybe align dst c n+ -- if it didn't inline, call the C function+ case mcode of+ Nothing -> libc_memset+ Just c -> pure c++ -- not literal size arguments: call the C function+ _ -> libc_memset++genMemSetInlineMaybe+ :: Int+ -> CmmExpr+ -> Integer+ -> Integer+ -> NatM (Maybe InstrBlock)+genMemSetInlineMaybe align dst c n = do+ config <- getConfig+ let+ platform = ncgPlatform config+ maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported+ effectiveAlignment = min (alignmentOf align) maxAlignment+ format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment+ c2 = c `shiftL` 8 .|. c+ c4 = c2 `shiftL` 16 .|. c2+ c8 = c4 `shiftL` 32 .|. c4++ -- The number of instructions we will generate (approx). We need 1+ -- instructions per move.+ insns = (n + sizeBytes - 1) `div` sizeBytes++ -- The size of each move, in bytes.+ sizeBytes :: Integer+ sizeBytes = fromIntegral (formatInBytes format)++ -- Depending on size returns the widest MOV instruction and its+ -- width.+ gen4 :: AddrMode -> Integer -> (InstrBlock, Integer)+ gen4 addr size+ | size >= 4 =+ (unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr addr)), 4)+ | size >= 2 =+ (unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr addr)), 2)+ | size >= 1 =+ (unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr addr)), 1)+ | otherwise = (nilOL, 0)++ -- Generates a 64-bit wide MOV instruction from REG to MEM.+ gen8 :: AddrMode -> Reg -> InstrBlock+ gen8 addr reg8byte =+ unitOL (MOV format (OpReg reg8byte) (OpAddr addr))++ -- Unrolls memset when the widest MOV is <= 4 bytes.+ go4 :: Reg -> Integer -> InstrBlock+ go4 dst left =+ if left <= 0 then nilOL+ else curMov `appOL` go4 dst (left - curWidth)+ where+ possibleWidth = minimum [left, sizeBytes]+ dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))+ (curMov, curWidth) = gen4 dst_addr possibleWidth++ -- Unrolls memset when the widest MOV is 8 bytes (thus another Reg+ -- argument). Falls back to go4 when all 8 byte moves are+ -- exhausted.+ go8 :: Reg -> Reg -> Integer -> InstrBlock+ go8 dst reg8byte left =+ if possibleWidth >= 8 then+ let curMov = gen8 dst_addr reg8byte+ in curMov `appOL` go8 dst reg8byte (left - 8)+ else go4 dst left+ where+ possibleWidth = minimum [left, sizeBytes]+ dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))++ if fromInteger insns > ncgInlineThresholdMemset config+ then pure Nothing+ else do+ code_dst <- getAnyReg dst+ dst_r <- getNewRegNat format+ if format == II64 && n >= 8+ then do+ code_imm8byte <- getAnyReg (CmmLit (CmmInt c8 W64))+ imm8byte_r <- getNewRegNat II64+ return $ Just $ code_dst dst_r `appOL`+ code_imm8byte imm8byte_r `appOL`+ go8 dst_r imm8byte_r (fromInteger n)+ else+ return $ Just $ code_dst dst_r `appOL`+ go4 dst_r (fromInteger n)+++genMemMove :: BlockId -> p -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock+genMemMove bid _align dst src n = do+ -- TODO: generate inline assembly when under a given treshold (similarly to+ -- memcpy and memset)+ genLibCCall bid (fsLit "memmove") [] [dst,src,n]++genMemCmp :: BlockId -> p -> CmmFormal -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock+genMemCmp bid _align res dst src n = do+ -- TODO: generate inline assembly when under a given treshold (similarly to+ -- memcpy and memset)+ genLibCCall bid (fsLit "memcmp") [res] [dst,src,n]++genPrefetchData :: Int -> CmmExpr -> NatM (OrdList Instr)+genPrefetchData n src = do+ is32Bit <- is32BitPlatform+ let+ format = archWordFormat is32Bit+ -- need to know what register width for pointers!+ genPrefetch inRegSrc prefetchCTor = do+ code_src <- getAnyReg inRegSrc+ src_r <- getNewRegNat format+ return $ code_src src_r `appOL`+ (unitOL (prefetchCTor (OpAddr+ ((AddrBaseIndex (EABaseReg src_r ) EAIndexNone (ImmInt 0)))) ))+ -- prefetch always takes an address++ -- the c / llvm prefetch convention is 0, 1, 2, and 3+ -- the x86 corresponding names are : NTA, 2 , 1, and 0+ case n of+ 0 -> genPrefetch src $ PREFETCH NTA format+ 1 -> genPrefetch src $ PREFETCH Lvl2 format+ 2 -> genPrefetch src $ PREFETCH Lvl1 format+ 3 -> genPrefetch src $ PREFETCH Lvl0 format+ l -> pprPanic "genPrefetchData: unexpected prefetch level" (ppr l)++genByteSwap :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock+genByteSwap width dst src = do+ is32Bit <- is32BitPlatform+ let format = intFormat width+ case width of+ W64 | is32Bit -> do+ let Reg64 dst_hi dst_lo = localReg64 dst+ RegCode64 vcode rhi rlo <- iselExpr64 src+ return $ vcode `appOL`+ toOL [ MOV II32 (OpReg rlo) (OpReg dst_hi),+ MOV II32 (OpReg rhi) (OpReg dst_lo),+ BSWAP II32 dst_hi,+ BSWAP II32 dst_lo ]+ W16 -> do+ let dst_r = getLocalRegReg dst+ code_src <- getAnyReg src+ return $ code_src dst_r `appOL`+ unitOL (BSWAP II32 dst_r) `appOL`+ unitOL (SHR II32 (OpImm $ ImmInt 16) (OpReg dst_r))+ _ -> do+ let dst_r = getLocalRegReg dst+ code_src <- getAnyReg src+ return $ code_src dst_r `appOL` unitOL (BSWAP format dst_r)++genBitRev :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock+genBitRev bid width dst src = do+ -- Here the C implementation (hs_bitrevN) is used as there is no x86+ -- instruction to reverse a word's bit order.+ genPrimCCall bid (bRevLabel width) [dst] [src]++genPopCnt :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM InstrBlock+genPopCnt bid width dst src = do+ config <- getConfig+ let+ platform = ncgPlatform config+ format = intFormat width++ sse4_2Enabled >>= \case++ True -> do+ code_src <- getAnyReg src+ src_r <- getNewRegNat format+ let dst_r = getRegisterReg platform (CmmLocal dst)+ return $ code_src src_r `appOL`+ (if width == W8 then+ -- The POPCNT instruction doesn't take a r/m8+ unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL`+ unitOL (POPCNT II16 (OpReg src_r) dst_r)+ else+ unitOL (POPCNT format (OpReg src_r) dst_r)) `appOL`+ (if width == W8 || width == W16 then+ -- We used a 16-bit destination register above,+ -- so zero-extend+ unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))+ else nilOL)++ False ->+ -- generate C call to hs_popcntN in ghc-prim+ -- TODO: we could directly generate the assembly to index popcount_tab+ -- here instead of doing it by calling a C function+ genPrimCCall bid (popCntLabel width) [dst] [src]+++genPdep :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genPdep bid width dst src mask = do+ config <- getConfig+ let+ platform = ncgPlatform config+ format = intFormat width++ if ncgBmiVersion config >= Just BMI2+ then do+ code_src <- getAnyReg src+ code_mask <- getAnyReg mask+ src_r <- getNewRegNat format+ mask_r <- getNewRegNat format+ let dst_r = getRegisterReg platform (CmmLocal dst)+ return $ code_src src_r `appOL` code_mask mask_r `appOL`+ -- PDEP only supports > 32 bit args+ ( if width == W8 || width == W16 then+ toOL+ [ MOVZxL format (OpReg src_r ) (OpReg src_r )+ , MOVZxL format (OpReg mask_r) (OpReg mask_r)+ , PDEP II32 (OpReg mask_r) (OpReg src_r ) dst_r+ , MOVZxL format (OpReg dst_r) (OpReg dst_r) -- Truncate to op width+ ]+ else+ unitOL (PDEP format (OpReg mask_r) (OpReg src_r) dst_r)+ )+ else+ -- generate C call to hs_pdepN in ghc-prim+ genPrimCCall bid (pdepLabel width) [dst] [src,mask]+++genPext :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genPext bid width dst src mask = do+ config <- getConfig+ if ncgBmiVersion config >= Just BMI2+ then do+ let format = intFormat width+ let dst_r = getLocalRegReg dst+ code_src <- getAnyReg src+ code_mask <- getAnyReg mask+ src_r <- getNewRegNat format+ mask_r <- getNewRegNat format+ return $ code_src src_r `appOL` code_mask mask_r `appOL`+ (if width == W8 || width == W16 then+ -- The PEXT instruction doesn't take a r/m8 or 16+ toOL+ [ MOVZxL format (OpReg src_r ) (OpReg src_r )+ , MOVZxL format (OpReg mask_r) (OpReg mask_r)+ , PEXT II32 (OpReg mask_r) (OpReg src_r ) dst_r+ , MOVZxL format (OpReg dst_r) (OpReg dst_r) -- Truncate to op width+ ]+ else+ unitOL (PEXT format (OpReg mask_r) (OpReg src_r) dst_r)+ )+ else+ -- generate C call to hs_pextN in ghc-prim+ genPrimCCall bid (pextLabel width) [dst] [src,mask]++genClz :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock+genClz bid width dst src = do+ is32Bit <- is32BitPlatform+ config <- getConfig+ if is32Bit && width == W64++ then+ -- Fallback to `hs_clz64` on i386+ genPrimCCall bid (clzLabel width) [dst] [src]++ else do+ code_src <- getAnyReg src+ let dst_r = getLocalRegReg dst+ if ncgBmiVersion config >= Just BMI2+ then do+ src_r <- getNewRegNat (intFormat width)+ return $ appOL (code_src src_r) $ case width of+ W8 -> toOL+ [ MOVZxL II8 (OpReg src_r) (OpReg src_r) -- zero-extend to 32 bit+ , LZCNT II32 (OpReg src_r) dst_r -- lzcnt with extra 24 zeros+ , SUB II32 (OpImm (ImmInt 24)) (OpReg dst_r) -- compensate for extra zeros+ ]+ W16 -> toOL+ [ LZCNT II16 (OpReg src_r) dst_r+ , MOVZxL II16 (OpReg dst_r) (OpReg dst_r) -- zero-extend from 16 bit+ ]+ _ -> unitOL (LZCNT (intFormat width) (OpReg src_r) dst_r)+ else do+ let format = if width == W8 then II16 else intFormat width+ let bw = widthInBits width+ src_r <- getNewRegNat format+ tmp_r <- getNewRegNat format+ return $ code_src src_r `appOL` toOL+ ([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] +++ [ BSR format (OpReg src_r) tmp_r+ , MOV II32 (OpImm (ImmInt (2*bw-1))) (OpReg dst_r)+ , CMOV NE format (OpReg tmp_r) dst_r+ , XOR format (OpImm (ImmInt (bw-1))) (OpReg dst_r)+ ]) -- NB: We don't need to zero-extend the result for the+ -- W8/W16 cases because the 'MOV' insn already+ -- took care of implicitly clearing the upper bits++genWordToFloat :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock+genWordToFloat bid width dst src =+ -- TODO: generate assembly instead+ genPrimCCall bid (word2FloatLabel width) [dst] [src]++genAtomicRead :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock+genAtomicRead width dst addr = do+ load_code <- intLoadCode (MOV (intFormat width)) addr+ return (load_code (getLocalRegReg dst))++genAtomicWrite :: Width -> CmmExpr -> CmmExpr -> NatM InstrBlock+genAtomicWrite width addr val = do+ code <- assignMem_IntCode (intFormat width) addr val+ return $ code `snocOL` MFENCE++genCmpXchg+ :: BlockId+ -> Width+ -> LocalReg+ -> CmmExpr+ -> CmmExpr+ -> CmmExpr+ -> NatM InstrBlock+genCmpXchg bid width dst addr old new = do+ is32Bit <- is32BitPlatform+ -- On x86 we don't have enough registers to use cmpxchg with a+ -- complicated addressing mode, so on that architecture we+ -- pre-compute the address first.+ if not (is32Bit && width == W64)+ then do+ let format = intFormat width+ Amode amode addr_code <- getSimpleAmode addr+ newval <- getNewRegNat format+ newval_code <- getAnyReg new+ oldval <- getNewRegNat format+ oldval_code <- getAnyReg old+ platform <- getPlatform+ let dst_r = getRegisterReg platform (CmmLocal dst)+ code = toOL+ [ MOV format (OpReg oldval) (OpReg eax)+ , LOCK (CMPXCHG format (OpReg newval) (OpAddr amode))+ , MOV format (OpReg eax) (OpReg dst_r)+ ]+ return $ addr_code `appOL` newval_code newval `appOL` oldval_code oldval+ `appOL` code+ else+ -- generate C call to hs_cmpxchgN in ghc-prim+ genPrimCCall bid (cmpxchgLabel width) [dst] [addr,old,new]+ -- TODO: implement cmpxchg8b instruction++genXchg :: Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genXchg width dst addr value = do+ is32Bit <- is32BitPlatform++ when (is32Bit && width == W64) $+ panic "genXchg: 64bit atomic exchange not supported on 32bit platforms"++ Amode amode addr_code <- getSimpleAmode addr+ (newval, newval_code) <- getSomeReg value+ let format = intFormat width+ let dst_r = getLocalRegReg dst+ -- Copy the value into the target register, perform the exchange.+ let code = toOL+ [ MOV format (OpReg newval) (OpReg dst_r)+ -- On X86 xchg implies a lock prefix if we use a memory argument.+ -- so this is atomic.+ , XCHG format (OpAddr amode) dst_r+ ]+ return $ addr_code `appOL` newval_code `appOL` code+++genFloatAbs :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock+genFloatAbs width dst src = do+ let+ format = floatFormat width+ const = case width of+ W32 -> CmmInt 0x7fffffff W32+ W64 -> CmmInt 0x7fffffffffffffff W64+ _ -> pprPanic "genFloatAbs: invalid width" (ppr width)+ src_code <- getAnyReg src+ Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes width) const+ tmp <- getNewRegNat format+ let dst_r = getLocalRegReg dst+ pure $ src_code dst_r `appOL` amode_code `appOL` toOL+ [ MOV format (OpAddr amode) (OpReg tmp)+ , AND format (OpReg tmp) (OpReg dst_r)+ ]+++genFloatSqrt :: Format -> LocalReg -> CmmExpr -> NatM InstrBlock+genFloatSqrt format dst src = do+ let dst_r = getLocalRegReg dst+ src_code <- getAnyReg src+ pure $ src_code dst_r `snocOL` SQRT format (OpReg dst_r) dst_r+++genAddSubRetCarry+ :: Width+ -> (Format -> Operand -> Operand -> Instr)+ -> (Format -> Maybe (Operand -> Operand -> Instr))+ -> Cond+ -> LocalReg+ -> LocalReg+ -> CmmExpr+ -> CmmExpr+ -> NatM InstrBlock+genAddSubRetCarry width instr mrevinstr cond res_r res_c arg_x arg_y = do+ platform <- ncgPlatform <$> getConfig+ let format = intFormat width+ rCode <- anyReg =<< trivialCode width (instr format)+ (mrevinstr format) arg_x arg_y+ reg_tmp <- getNewRegNat II8+ let reg_c = getRegisterReg platform (CmmLocal res_c)+ reg_r = getRegisterReg platform (CmmLocal res_r)+ code = rCode reg_r `snocOL`+ SETCC cond (OpReg reg_tmp) `snocOL`+ MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)+ return code+++genAddWithCarry+ :: Width+ -> LocalReg+ -> LocalReg+ -> CmmExpr+ -> CmmExpr+ -> NatM InstrBlock+genAddWithCarry width res_h res_l arg_x arg_y = do+ hCode <- getAnyReg (CmmLit (CmmInt 0 width))+ let format = intFormat width+ lCode <- anyReg =<< trivialCode width (ADD_CC format)+ (Just (ADD_CC format)) arg_x arg_y+ let reg_l = getLocalRegReg res_l+ reg_h = getLocalRegReg res_h+ code = hCode reg_h `appOL`+ lCode reg_l `snocOL`+ ADC format (OpImm (ImmInteger 0)) (OpReg reg_h)+ return code+++genSignedLargeMul+ :: Width+ -> LocalReg+ -> LocalReg+ -> LocalReg+ -> CmmExpr+ -> CmmExpr+ -> NatM (OrdList Instr)+genSignedLargeMul width res_c res_h res_l arg_x arg_y = do+ (y_reg, y_code) <- getRegOrMem arg_y+ x_code <- getAnyReg arg_x+ reg_tmp <- getNewRegNat II8+ let format = intFormat width+ reg_h = getLocalRegReg res_h+ reg_l = getLocalRegReg res_l+ reg_c = getLocalRegReg res_c+ code = y_code `appOL`+ x_code rax `appOL`+ toOL [ IMUL2 format y_reg+ , MOV format (OpReg rdx) (OpReg reg_h)+ , MOV format (OpReg rax) (OpReg reg_l)+ , SETCC CARRY (OpReg reg_tmp)+ , MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)+ ]+ return code++genUnsignedLargeMul+ :: Width+ -> LocalReg+ -> LocalReg+ -> CmmExpr+ -> CmmExpr+ -> NatM (OrdList Instr)+genUnsignedLargeMul width res_h res_l arg_x arg_y = do+ (y_reg, y_code) <- getRegOrMem arg_y+ x_code <- getAnyReg arg_x+ let format = intFormat width+ reg_h = getLocalRegReg res_h+ reg_l = getLocalRegReg res_l+ code = y_code `appOL`+ x_code rax `appOL`+ toOL [MUL2 format y_reg,+ MOV format (OpReg rdx) (OpReg reg_h),+ MOV format (OpReg rax) (OpReg reg_l)]+ return code+++genQuotRem+ :: Width+ -> Bool+ -> LocalReg+ -> LocalReg+ -> Maybe CmmExpr+ -> CmmExpr+ -> CmmExpr+ -> NatM InstrBlock+genQuotRem width signed res_q res_r m_arg_x_high arg_x_low arg_y = do+ case width of+ W8 -> do+ -- See Note [DIV/IDIV for bytes]+ let widen | signed = MO_SS_Conv W8 W16+ | otherwise = MO_UU_Conv W8 W16+ arg_x_low_16 = CmmMachOp widen [arg_x_low]+ arg_y_16 = CmmMachOp widen [arg_y]+ m_arg_x_high_16 = (\p -> CmmMachOp widen [p]) <$> m_arg_x_high+ genQuotRem W16 signed res_q res_r m_arg_x_high_16 arg_x_low_16 arg_y_16++ _ -> do+ let format = intFormat width+ reg_q = getLocalRegReg res_q+ reg_r = getLocalRegReg res_r+ widen | signed = CLTD format+ | otherwise = XOR format (OpReg rdx) (OpReg rdx)+ instr | signed = IDIV+ | otherwise = DIV+ (y_reg, y_code) <- getRegOrMem arg_y+ x_low_code <- getAnyReg arg_x_low+ x_high_code <- case m_arg_x_high of+ Just arg_x_high ->+ getAnyReg arg_x_high+ Nothing ->+ return $ const $ unitOL widen+ return $ y_code `appOL`+ x_low_code rax `appOL`+ x_high_code rdx `appOL`+ toOL [instr format y_reg,+ MOV format (OpReg rax) (OpReg reg_q),+ MOV format (OpReg rdx) (OpReg reg_r)]+++----------------------------------------------------------------------------+-- The following functions implement certain 64-bit MachOps inline for 32-bit+-- architectures. On 64-bit architectures, those MachOps aren't supported and+-- calling these functions for a 64-bit target platform is considered an error+-- (hence the use of `expect32BitPlatform`).+--+-- On 64-bit platforms, generic MachOps should be used instead of these 64-bit+-- specific ones (e.g. use MO_Add instead of MO_x64_Add). This MachOp selection+-- is done by StgToCmm.++genInt64ToInt :: LocalReg -> CmmExpr -> NatM InstrBlock+genInt64ToInt dst src = do+ expect32BitPlatform (text "genInt64ToInt")+ RegCode64 code _src_hi src_lo <- iselExpr64 src+ let dst_r = getLocalRegReg dst+ pure $ code `snocOL` MOV II32 (OpReg src_lo) (OpReg dst_r)++genWord64ToWord :: LocalReg -> CmmExpr -> NatM InstrBlock+genWord64ToWord dst src = do+ expect32BitPlatform (text "genWord64ToWord")+ RegCode64 code _src_hi src_lo <- iselExpr64 src+ let dst_r = getLocalRegReg dst+ pure $ code `snocOL` MOV II32 (OpReg src_lo) (OpReg dst_r)++genIntToInt64 :: LocalReg -> CmmExpr -> NatM InstrBlock+genIntToInt64 dst src = do+ expect32BitPlatform (text "genIntToInt64")+ let Reg64 dst_hi dst_lo = localReg64 dst+ src_code <- getAnyReg src+ pure $ src_code rax `appOL` toOL+ [ CLTD II32 -- sign extend EAX in EDX:EAX+ , MOV II32 (OpReg rax) (OpReg dst_lo)+ , MOV II32 (OpReg rdx) (OpReg dst_hi)+ ]++genWordToWord64 :: LocalReg -> CmmExpr -> NatM InstrBlock+genWordToWord64 dst src = do+ expect32BitPlatform (text "genWordToWord64")+ let Reg64 dst_hi dst_lo = localReg64 dst+ src_code <- getAnyReg src+ pure $ src_code dst_lo+ `snocOL` XOR II32 (OpReg dst_hi) (OpReg dst_hi)++genNeg64 :: LocalReg -> CmmExpr -> NatM InstrBlock+genNeg64 dst src = do+ expect32BitPlatform (text "genNeg64")+ let Reg64 dst_hi dst_lo = localReg64 dst+ RegCode64 code src_hi src_lo <- iselExpr64 src+ pure $ code `appOL` toOL+ [ MOV II32 (OpReg src_lo) (OpReg dst_lo)+ , MOV II32 (OpReg src_hi) (OpReg dst_hi)+ , NEGI II32 (OpReg dst_lo)+ , ADC II32 (OpImm (ImmInt 0)) (OpReg dst_hi)+ , NEGI II32 (OpReg dst_hi)+ ]++genAdd64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genAdd64 dst x y = do+ expect32BitPlatform (text "genAdd64")+ let Reg64 dst_hi dst_lo = localReg64 dst+ RegCode64 x_code x_hi x_lo <- iselExpr64 x+ RegCode64 y_code y_hi y_lo <- iselExpr64 y+ pure $ x_code `appOL` y_code `appOL` toOL+ [ MOV II32 (OpReg x_lo) (OpReg dst_lo)+ , MOV II32 (OpReg x_hi) (OpReg dst_hi)+ , ADD II32 (OpReg y_lo) (OpReg dst_lo)+ , ADC II32 (OpReg y_hi) (OpReg dst_hi)+ ]++genSub64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genSub64 dst x y = do+ expect32BitPlatform (text "genSub64")+ let Reg64 dst_hi dst_lo = localReg64 dst+ RegCode64 x_code x_hi x_lo <- iselExpr64 x+ RegCode64 y_code y_hi y_lo <- iselExpr64 y+ pure $ x_code `appOL` y_code `appOL` toOL+ [ MOV II32 (OpReg x_lo) (OpReg dst_lo)+ , MOV II32 (OpReg x_hi) (OpReg dst_hi)+ , SUB II32 (OpReg y_lo) (OpReg dst_lo)+ , SBB II32 (OpReg y_hi) (OpReg dst_hi)+ ]++genAnd64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genAnd64 dst x y = do+ expect32BitPlatform (text "genAnd64")+ let Reg64 dst_hi dst_lo = localReg64 dst+ RegCode64 x_code x_hi x_lo <- iselExpr64 x+ RegCode64 y_code y_hi y_lo <- iselExpr64 y+ pure $ x_code `appOL` y_code `appOL` toOL+ [ MOV II32 (OpReg x_lo) (OpReg dst_lo)+ , MOV II32 (OpReg x_hi) (OpReg dst_hi)+ , AND II32 (OpReg y_lo) (OpReg dst_lo)+ , AND II32 (OpReg y_hi) (OpReg dst_hi)+ ]++genOr64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genOr64 dst x y = do+ expect32BitPlatform (text "genOr64")+ let Reg64 dst_hi dst_lo = localReg64 dst+ RegCode64 x_code x_hi x_lo <- iselExpr64 x+ RegCode64 y_code y_hi y_lo <- iselExpr64 y+ pure $ x_code `appOL` y_code `appOL` toOL+ [ MOV II32 (OpReg x_lo) (OpReg dst_lo)+ , MOV II32 (OpReg x_hi) (OpReg dst_hi)+ , OR II32 (OpReg y_lo) (OpReg dst_lo)+ , OR II32 (OpReg y_hi) (OpReg dst_hi)+ ]++genXor64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genXor64 dst x y = do+ expect32BitPlatform (text "genXor64")+ let Reg64 dst_hi dst_lo = localReg64 dst+ RegCode64 x_code x_hi x_lo <- iselExpr64 x+ RegCode64 y_code y_hi y_lo <- iselExpr64 y+ pure $ x_code `appOL` y_code `appOL` toOL+ [ MOV II32 (OpReg x_lo) (OpReg dst_lo)+ , MOV II32 (OpReg x_hi) (OpReg dst_hi)+ , XOR II32 (OpReg y_lo) (OpReg dst_lo)+ , XOR II32 (OpReg y_hi) (OpReg dst_hi)+ ]++genNot64 :: LocalReg -> CmmExpr -> NatM InstrBlock+genNot64 dst src = do+ expect32BitPlatform (text "genNot64")+ let Reg64 dst_hi dst_lo = localReg64 dst+ RegCode64 src_code src_hi src_lo <- iselExpr64 src+ pure $ src_code `appOL` toOL+ [ MOV II32 (OpReg src_lo) (OpReg dst_lo)+ , MOV II32 (OpReg src_hi) (OpReg dst_hi)+ , NOT II32 (OpReg dst_lo)+ , NOT II32 (OpReg dst_hi)+ ]++genEq64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genEq64 dst x y = do+ expect32BitPlatform (text "genEq64")+ let dst_r = getLocalRegReg dst+ RegCode64 x_code x_hi x_lo <- iselExpr64 x+ RegCode64 y_code y_hi y_lo <- iselExpr64 y+ Reg64 tmp_hi tmp_lo <- getNewReg64+ pure $ x_code `appOL` y_code `appOL` toOL+ [ MOV II32 (OpReg x_lo) (OpReg tmp_lo)+ , MOV II32 (OpReg x_hi) (OpReg tmp_hi)+ , XOR II32 (OpReg y_lo) (OpReg tmp_lo)+ , XOR II32 (OpReg y_hi) (OpReg tmp_hi)+ , OR II32 (OpReg tmp_lo) (OpReg tmp_hi)+ , SETCC EQQ (OpReg dst_r)+ , MOVZxL II8 (OpReg dst_r) (OpReg dst_r)+ ]++genNe64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genNe64 dst x y = do+ expect32BitPlatform (text "genNe64")+ let dst_r = getLocalRegReg dst+ RegCode64 x_code x_hi x_lo <- iselExpr64 x+ RegCode64 y_code y_hi y_lo <- iselExpr64 y+ Reg64 tmp_hi tmp_lo <- getNewReg64+ pure $ x_code `appOL` y_code `appOL` toOL+ [ MOV II32 (OpReg x_lo) (OpReg tmp_lo)+ , MOV II32 (OpReg x_hi) (OpReg tmp_hi)+ , XOR II32 (OpReg y_lo) (OpReg tmp_lo)+ , XOR II32 (OpReg y_hi) (OpReg tmp_hi)+ , OR II32 (OpReg tmp_lo) (OpReg tmp_hi)+ , SETCC NE (OpReg dst_r)+ , MOVZxL II8 (OpReg dst_r) (OpReg dst_r)+ ]++genGtWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genGtWord64 dst x y = do+ expect32BitPlatform (text "genGtWord64")+ genPred64 LU dst y x++genLtWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genLtWord64 dst x y = do+ expect32BitPlatform (text "genLtWord64")+ genPred64 LU dst x y++genGeWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genGeWord64 dst x y = do+ expect32BitPlatform (text "genGeWord64")+ genPred64 GEU dst x y++genLeWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genLeWord64 dst x y = do+ expect32BitPlatform (text "genLeWord64")+ genPred64 GEU dst y x++genGtInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genGtInt64 dst x y = do+ expect32BitPlatform (text "genGtInt64")+ genPred64 LTT dst y x++genLtInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genLtInt64 dst x y = do+ expect32BitPlatform (text "genLtInt64")+ genPred64 LTT dst x y++genGeInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genGeInt64 dst x y = do+ expect32BitPlatform (text "genGeInt64")+ genPred64 GE dst x y++genLeInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genLeInt64 dst x y = do+ expect32BitPlatform (text "genLeInt64")+ genPred64 GE dst y x++genPred64 :: Cond -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genPred64 cond dst x y = do+ -- we can only rely on CF/SF/OF flags!+ -- Not on ZF, which doesn't take into account the lower parts.+ massert (cond `elem` [LU,GEU,LTT,GE])++ let dst_r = getLocalRegReg dst+ RegCode64 x_code x_hi x_lo <- iselExpr64 x+ RegCode64 y_code y_hi y_lo <- iselExpr64 y+ -- Basically we perform a subtraction with borrow.+ -- As we don't need to result, we can use CMP instead of SUB for the low part+ -- (it sets the borrow flag just like SUB does)+ pure $ x_code `appOL` y_code `appOL` toOL+ [ MOV II32 (OpReg x_hi) (OpReg dst_r)+ , CMP II32 (OpReg y_lo) (OpReg x_lo)+ , SBB II32 (OpReg y_hi) (OpReg dst_r)+ , SETCC cond (OpReg dst_r)+ , MOVZxL II8 (OpReg dst_r) (OpReg dst_r)+ ]+
compiler/GHC/CmmToAsm/X86/Cond.hs view
@@ -11,22 +11,22 @@ data Cond = ALWAYS -- What's really used? ToDo- | EQQ -- je/jz -> zf = 1- | GE -- jge- | GEU -- ae- | GTT -- jg- | GU -- ja- | LE -- jle- | LEU -- jbe- | LTT -- jl- | LU -- jb- | NE -- jne- | NEG -- js- | POS -- jns- | CARRY -- jc- | OFLO -- jo- | PARITY -- jp- | NOTPARITY -- jnp+ | EQQ -- je/jz -> zf=1+ | GE -- jge -> sf=of+ | GEU -- ae -> cf=0+ | GTT -- jg -> zf=0 && sf=of+ | GU -- ja -> cf=0 && zf=0+ | LE -- jle -> zf=1 || sf/=of+ | LEU -- jbe -> cf=1 || zf=1+ | LTT -- jl -> sf/=of+ | LU -- jb -> cf=1+ | NE -- jne -> zf=0+ | NEG -- js -> sf=1+ | POS -- jns -> sf=0+ | CARRY -- jc -> cf=1+ | OFLO -- jo -> of=1+ | PARITY -- jp -> pf=1+ | NOTPARITY -- jnp -> pf=0 deriving Eq condToUnsigned :: Cond -> Cond
compiler/GHC/CmmToAsm/X86/Instr.hs view
@@ -120,7 +120,7 @@ {- Note [x86 Floating point precision]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Intel's internal floating point registers are by default 80 bit extended precision. This means that all operations done on values in registers are done at 80 bits, and unless the intermediate values are@@ -795,6 +795,8 @@ = [JXX ALWAYS id] -- Note [Windows stack layout]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+ -- | On most OSes the kernel will place a guard page after the current stack -- page. If you allocate larger than a page worth you may jump over this -- guard page. Not only is this a security issue, but on certain OSes such@@ -851,7 +853,7 @@ -- there are no expectations for volatile registers. -- -- 3. When the target is a local branch point it is re-targeted- -- after the dealloc, preserving #2. See note [extra spill slots].+ -- after the dealloc, preserving #2. See Note [extra spill slots]. -- -- We emit a call because the stack probes are quite involved and -- would bloat code size a lot. GHC doesn't really have an -Os.@@ -896,9 +898,8 @@ _ -> panic "X86.mkStackDeallocInstr" --- -- Note [extra spill slots]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~ -- If the register allocator used more spill slots than we have -- pre-allocated (rESERVED_C_STACK_BYTES), then we must allocate more -- C stack space on entry and exit from this proc. Therefore we
compiler/GHC/CmmToAsm/X86/Ppr.hs view
@@ -48,12 +48,8 @@ import Data.Word --- -------------------------------------------------------------------------------- Printing this stuff out------ -- Note [Subsections Via Symbols]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- If we are using the .subsections_via_symbols directive -- (available on recent versions of Darwin), -- we have to make sure that there is some kind of reference@@ -163,14 +159,14 @@ ppWhen (ncgDwarfEnabled config) (pdoc platform (mkAsmTempEndLabel infoLbl) <> colon) -- Make sure the info table has the right .loc for the block- -- coming right after it. See [Note: Info Offset]+ -- coming right after it. See Note [Info Offset] infoTableLoc = case instrs of (l@LOCATION{} : _) -> pprInstr platform l _other -> empty pprDatas :: NCGConfig -> (Alignment, RawCmmStatics) -> SDoc--- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".+-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". pprDatas config (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l
compiler/GHC/CmmToC.hs view
@@ -167,6 +167,7 @@ text "__attribute__((aligned(" <> int (widthInBytes words) <> text ")))" -- Note [StgWord alignment]+-- ~~~~~~~~~~~~~~~~~~~~~~~~ -- C codegen builds static closures as StgWord C arrays (pprWordArray). -- Their real C type is 'StgClosure'. Macros like UNTAG_CLOSURE assume -- pointers to 'StgClosure' are aligned at pointer size boundary:@@ -213,14 +214,14 @@ CmmAssign dest src -> pprAssign platform dest src - CmmStore dest src+ CmmStore dest src align | typeWidth rep == W64 && wordWidth platform /= W64 -> (if isFloatType rep then text "ASSIGN_DBL" else text "ASSIGN_Word64") <> parens (mkP_ <> pprExpr1 platform dest <> comma <> pprExpr platform src) <> semi | otherwise- -> hsep [ pprExpr platform (CmmLoad dest rep), equals, pprExpr platform src <> semi ]+ -> hsep [ pprExpr platform (CmmLoad dest rep align), equals, pprExpr platform src <> semi ] where rep = cmmExprType platform src @@ -375,10 +376,10 @@ pprExpr :: Platform -> CmmExpr -> SDoc pprExpr platform e = case e of- CmmLit lit -> pprLit platform lit- CmmLoad e ty -> pprLoad platform e ty- CmmReg reg -> pprCastReg reg- CmmRegOff reg 0 -> pprCastReg reg+ CmmLit lit -> pprLit platform lit+ CmmLoad e ty align -> pprLoad platform e ty align+ CmmReg reg -> pprCastReg reg+ CmmRegOff reg 0 -> pprCastReg reg -- CmmRegOff is an alias of MO_Add CmmRegOff reg i -> pprCastReg reg <> char '+' <>@@ -389,13 +390,14 @@ CmmStackSlot _ _ -> panic "pprExpr: CmmStackSlot not supported!" -pprLoad :: Platform -> CmmExpr -> CmmType -> SDoc-pprLoad platform e ty+pprLoad :: Platform -> CmmExpr -> CmmType -> AlignmentSpec -> SDoc+pprLoad platform e ty _align | width == W64, wordWidth platform /= W64 = (if isFloatType ty then text "PK_DBL" else text "PK_Word64") <> parens (mkP_ <> pprExpr1 platform e) + -- TODO: exploit natural-alignment where possible | otherwise = case e of CmmReg r | isPtrReg r && width == wordWidth platform && not (isFloatType ty)@@ -495,7 +497,7 @@ -- resultRepOfMachOp says). | isComparisonMachOp mop = Just mkW_ - -- See Note [Zero-extended sub-word signed results]+ -- See Note [Zero-extending sub-word signed results] | signedOp mop , res_ty <- machOpResultType platform mop args , not $ isFloatType res_ty -- only integer operations, not MO_SF_Conv@@ -1268,7 +1270,7 @@ te_Stmt :: CmmNode e x -> TE () te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e-te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r+te_Stmt (CmmStore l r _) = te_Expr l >> te_Expr r te_Stmt (CmmUnsafeForeignCall target rs es) = do te_Target target mapM_ te_temp rs@@ -1284,7 +1286,7 @@ te_Expr :: CmmExpr -> TE () te_Expr (CmmLit lit) = te_Lit lit-te_Expr (CmmLoad e _) = te_Expr e+te_Expr (CmmLoad e _ _) = te_Expr e te_Expr (CmmReg r) = te_Reg r te_Expr (CmmMachOp _ es) = mapM_ te_Expr es te_Expr (CmmRegOff r _) = te_Reg r
compiler/GHC/CmmToLlvm/Base.hs view
@@ -553,7 +553,7 @@ -- | Here we take a global variable definition, rename it with a -- @$def@ suffix, and generate the appropriate alias. aliasify :: LMGlobal -> LlvmM [LMGlobal]--- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".+-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". -- Here we obtain the indirectee's precise type and introduce -- fresh aliases to both the precise typed label (lbl$def) and the i8* -- typed (regular) label of it with the matching new names.@@ -591,7 +591,7 @@ ] -- Note [Llvm Forward References]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- The issue here is that LLVM insists on being strongly typed at -- every corner, so the first time we mention something, we have to -- settle what type we assign to it. That makes things awkward, as Cmm
compiler/GHC/CmmToLlvm/CodeGen.hs view
@@ -126,7 +126,8 @@ CmmUnwind {} -> return (nilOL, []) CmmAssign reg src -> genAssign reg src- CmmStore addr src -> genStore addr src+ CmmStore addr src align+ -> genStore addr src align CmmBranch id -> genBranch id CmmCondBranch arg true false likely@@ -207,7 +208,7 @@ castV <- lift $ mkLocalVar ty ve <- exprToVarW e statement $ Assignment castV $ Cast LM_Uitofp ve width- statement $ Store castV dstV+ statement $ Store castV dstV Nothing genCall (PrimTarget (MO_UF_Conv _)) [_] args = panic $ "genCall: Too many arguments to MO_UF_Conv. " ++@@ -263,12 +264,12 @@ AMO_Or -> LAO_Or AMO_Xor -> LAO_Xor retVar <- doExprW targetTy $ AtomicRMW op ptrVar nVar SyncSeqCst- statement $ Store retVar dstVar+ statement $ Store retVar dstVar Nothing genCall (PrimTarget (MO_AtomicRead _)) [dst] [addr] = runStmtsDecls $ do dstV <- getCmmRegW (CmmLocal dst)- v1 <- genLoadW True addr (localRegType dst)- statement $ Store v1 dstV+ v1 <- genLoadW True addr (localRegType dst) NaturallyAligned+ statement $ Store v1 dstV Nothing genCall (PrimTarget (MO_Cmpxchg _width)) [dst] [addr, old, new] = runStmtsDecls $ do@@ -282,7 +283,7 @@ retVar <- doExprW (LMStructU [targetTy,i1]) $ CmpXChg ptrVar oldVar newVar SyncSeqCst SyncSeqCst retVar' <- doExprW targetTy $ ExtractV retVar 0- statement $ Store retVar' dstVar+ statement $ Store retVar' dstVar Nothing genCall (PrimTarget (MO_Xchg _width)) [dst] [addr, val] = runStmtsDecls $ do dstV <- getCmmRegW (CmmLocal dst) :: WriterT LlvmAccum LlvmM LlvmVar@@ -292,7 +293,7 @@ ptrExpr = Cast LM_Inttoptr addrVar ptrTy ptrVar <- doExprW ptrTy ptrExpr resVar <- doExprW (getVarType valVar) (AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst)- statement $ Store resVar dstV+ statement $ Store resVar dstV Nothing genCall (PrimTarget (MO_AtomicWrite _width)) [] [addr, val] = runStmtsDecls $ do addrVar <- exprToVarW addr@@ -352,8 +353,8 @@ retH <- doExprW width $ Cast LM_Trunc retShifted width dstRegL <- getCmmRegW (CmmLocal dstL) dstRegH <- getCmmRegW (CmmLocal dstH)- statement $ Store retL dstRegL- statement $ Store retH dstRegH+ statement $ Store retL dstRegL Nothing+ statement $ Store retH dstRegH Nothing genCall (PrimTarget (MO_S_Mul2 w)) [dstC, dstH, dstL] [lhs, rhs] = runStmtsDecls $ do let width = widthToLlvmInt w@@ -384,9 +385,9 @@ dstRegL <- getCmmRegW (CmmLocal dstL) dstRegH <- getCmmRegW (CmmLocal dstH) dstRegC <- getCmmRegW (CmmLocal dstC)- statement $ Store retL dstRegL- statement $ Store retH dstRegH- statement $ Store retC dstRegC+ statement $ Store retL dstRegL Nothing+ statement $ Store retH dstRegH Nothing+ statement $ Store retC dstRegC Nothing -- MO_U_QuotRem2 is another case we handle by widening the registers to double -- the width and use normal LLVM instructions (similarly to the MO_U_Mul2). The@@ -420,8 +421,8 @@ retRem <- narrow retExtRem dstRegQ <- lift $ getCmmReg (CmmLocal dstQ) dstRegR <- lift $ getCmmReg (CmmLocal dstR)- statement $ Store retDiv dstRegQ- statement $ Store retRem dstRegR+ statement $ Store retDiv dstRegQ Nothing+ statement $ Store retRem dstRegR Nothing -- Handle the MO_{Add,Sub}IntC separately. LLVM versions return a record from -- which we need to extract the actual values.@@ -528,7 +529,7 @@ vreg <- getCmmRegW (CmmLocal creg) if retTy == pLower (getVarType vreg) then do- statement $ Store v1 vreg+ statement $ Store v1 vreg Nothing doReturn else do let ty = pLower $ getVarType vreg@@ -540,7 +541,7 @@ ++ " returned type!" v2 <- doExprW ty $ Cast op v1 ty- statement $ Store v2 vreg+ statement $ Store v2 vreg Nothing doReturn -- | Generate a call to an LLVM intrinsic that performs arithmetic operation@@ -569,8 +570,8 @@ (overflow, zext) <- doExpr width $ Cast LM_Zext overflowBit width dstRegV <- getCmmReg (CmmLocal dstV) dstRegO <- getCmmReg (CmmLocal dstO)- let storeV = Store value dstRegV- storeO = Store overflow dstRegO+ let storeV = Store value dstRegV Nothing+ storeO = Store overflow dstRegO Nothing return (stmts `snocOL` zext `snocOL` storeV `snocOL` storeO, top) genCallWithOverflow _ _ _ _ = panic "genCallExtract: wrong ForeignTarget or number of arguments"@@ -635,7 +636,7 @@ (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] (retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)] let retV' = singletonPanic "genCallSimpleCast" retVs'- let s2 = Store retV' dstV+ let s2 = Store retV' dstV Nothing let stmts = stmts2 `appOL` stmts4 `snocOL` s1 `appOL` stmts5 `snocOL` s2@@ -667,7 +668,7 @@ (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] (retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)] let retV' = singletonPanic "genCallSimpleCast2" retVs'- let s2 = Store retV' dstV+ let s2 = Store retV' dstV Nothing let stmts = stmts2 `appOL` stmts4 `snocOL` s1 `appOL` stmts5 `snocOL` s2@@ -1097,54 +1098,54 @@ -- Some registers are pointer types, so need to cast value to pointer LMPointer _ | getVarType vval == llvmWord platform -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty- let s2 = Store v vreg+ let s2 = Store v vreg Nothing return (stmts `snocOL` s1 `snocOL` s2, top2) LMVector _ _ -> do (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty- let s2 = Store v vreg+ let s2 = mkStore v vreg NaturallyAligned return (stmts `snocOL` s1 `snocOL` s2, top2) _ -> do- let s1 = Store vval vreg+ let s1 = Store vval vreg Nothing return (stmts `snocOL` s1, top2) -- | CmmStore operation-genStore :: CmmExpr -> CmmExpr -> LlvmM StmtData+genStore :: CmmExpr -> CmmExpr -> AlignmentSpec -> LlvmM StmtData -- First we try to detect a few common cases and produce better code for -- these then the default case. We are mostly trying to detect Cmm code -- like I32[Sp + n] and use 'getelementptr' operations instead of the -- generic case that uses casts and pointer arithmetic-genStore addr@(CmmReg (CmmGlobal r)) val- = genStore_fast addr r 0 val+genStore addr@(CmmReg (CmmGlobal r)) val alignment+ = genStore_fast addr r 0 val alignment -genStore addr@(CmmRegOff (CmmGlobal r) n) val- = genStore_fast addr r n val+genStore addr@(CmmRegOff (CmmGlobal r) n) val alignment+ = genStore_fast addr r n val alignment genStore addr@(CmmMachOp (MO_Add _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))])- val- = genStore_fast addr r (fromInteger n) val+ val alignment+ = genStore_fast addr r (fromInteger n) val alignment genStore addr@(CmmMachOp (MO_Sub _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))])- val- = genStore_fast addr r (negate $ fromInteger n) val+ val alignment+ = genStore_fast addr r (negate $ fromInteger n) val alignment -- generic case-genStore addr val- = getTBAAMeta topN >>= genStore_slow addr val+genStore addr val alignment+ = getTBAAMeta topN >>= genStore_slow addr val alignment -- | CmmStore operation -- This is a special case for storing to a global register pointer -- offset such as I32[Sp+8].-genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr+genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr -> AlignmentSpec -> LlvmM StmtData-genStore_fast addr r n val+genStore_fast addr r n val alignment = do platform <- getPlatform (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) meta <- getTBAARegMeta r@@ -1157,7 +1158,7 @@ case pLower grt == getVarType vval of -- were fine True -> do- let s3 = MetaStmt meta $ Store vval ptr+ let s3 = MetaStmt meta $ mkStore vval ptr alignment return (stmts `appOL` s1 `snocOL` s2 `snocOL` s3, top) @@ -1165,19 +1166,19 @@ False -> do let ty = (pLift . getVarType) vval (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty- let s4 = MetaStmt meta $ Store vval ptr'+ let s4 = MetaStmt meta $ mkStore vval ptr' alignment return (stmts `appOL` s1 `snocOL` s2 `snocOL` s3 `snocOL` s4, top) -- If its a bit type then we use the slow method since -- we can't avoid casting anyway.- False -> genStore_slow addr val meta+ False -> genStore_slow addr val alignment meta -- | CmmStore operation -- Generic case. Uses casts and pointer arithmetic if needed.-genStore_slow :: CmmExpr -> CmmExpr -> [MetaAnnot] -> LlvmM StmtData-genStore_slow addr val meta = do+genStore_slow :: CmmExpr -> CmmExpr -> AlignmentSpec -> [MetaAnnot] -> LlvmM StmtData+genStore_slow addr val alignment meta = do (vaddr, stmts1, top1) <- exprToVar addr (vval, stmts2, top2) <- exprToVar val @@ -1188,17 +1189,17 @@ -- sometimes we need to cast an int to a pointer before storing LMPointer ty@(LMPointer _) | getVarType vval == llvmWord platform -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty- let s2 = MetaStmt meta $ Store v vaddr+ let s2 = MetaStmt meta $ mkStore v vaddr alignment return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) LMPointer _ -> do- let s1 = MetaStmt meta $ Store vval vaddr+ let s1 = MetaStmt meta $ mkStore vval vaddr alignment return (stmts `snocOL` s1, top1 ++ top2) i@(LMInt _) | i == llvmWord platform -> do let vty = pLift $ getVarType vval (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty- let s2 = MetaStmt meta $ Store vval vptr+ let s2 = MetaStmt meta $ mkStore vval vptr alignment return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) other ->@@ -1208,6 +1209,16 @@ ", Size of var: " ++ show (llvmWidthInBits platform other) ++ ", Var: " ++ renderWithContext (llvmCgContext cfg) (ppVar cfg vaddr))) +mkStore :: LlvmVar -> LlvmVar -> AlignmentSpec -> LlvmStatement+mkStore vval vptr alignment =+ Store vval vptr align+ where+ ty = pLower (getVarType vptr)+ align = case alignment of+ -- See Note [Alignment of vector-typed values]+ _ | isVector ty -> Just 1+ Unaligned -> Just 1+ NaturallyAligned -> Nothing -- | Unconditional branch genBranch :: BlockId -> LlvmM StmtData@@ -1255,7 +1266,6 @@ {- Note [Literals and branch conditions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- It is important that whenever we generate branch conditions for literals like '1', they are properly narrowed to an LLVM expression of type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert@@ -1358,8 +1368,8 @@ CmmLit lit -> genLit opt lit - CmmLoad e' ty- -> genLoad False e' ty+ CmmLoad e' ty align+ -> genLoad False e' ty align -- Cmmreg in expression is the value, so must load. If you want actual -- reg pointer, call getCmmReg directly.@@ -1791,40 +1801,40 @@ -- | Handle CmmLoad expression.-genLoad :: Atomic -> CmmExpr -> CmmType -> LlvmM ExprData+genLoad :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> LlvmM ExprData -- First we try to detect a few common cases and produce better code for -- these then the default case. We are mostly trying to detect Cmm code -- like I32[Sp + n] and use 'getelementptr' operations instead of the -- generic case that uses casts and pointer arithmetic-genLoad atomic e@(CmmReg (CmmGlobal r)) ty- = genLoad_fast atomic e r 0 ty+genLoad atomic e@(CmmReg (CmmGlobal r)) ty align+ = genLoad_fast atomic e r 0 ty align -genLoad atomic e@(CmmRegOff (CmmGlobal r) n) ty- = genLoad_fast atomic e r n ty+genLoad atomic e@(CmmRegOff (CmmGlobal r) n) ty align+ = genLoad_fast atomic e r n ty align genLoad atomic e@(CmmMachOp (MO_Add _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))])- ty- = genLoad_fast atomic e r (fromInteger n) ty+ ty align+ = genLoad_fast atomic e r (fromInteger n) ty align genLoad atomic e@(CmmMachOp (MO_Sub _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))])- ty- = genLoad_fast atomic e r (negate $ fromInteger n) ty+ ty align+ = genLoad_fast atomic e r (negate $ fromInteger n) ty align -- generic case-genLoad atomic e ty- = getTBAAMeta topN >>= genLoad_slow atomic e ty+genLoad atomic e ty align+ = getTBAAMeta topN >>= genLoad_slow atomic e ty align -- | Handle CmmLoad expression. -- This is a special case for loading from a global register pointer -- offset such as I32[Sp+8]. genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType- -> LlvmM ExprData-genLoad_fast atomic e r n ty = do+ -> AlignmentSpec -> LlvmM ExprData+genLoad_fast atomic e r n ty align = do platform <- getPlatform (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) meta <- getTBAARegMeta r@@ -1837,7 +1847,7 @@ case grt == ty' of -- were fine True -> do- (var, s3) <- doExpr ty' (MExpr meta $ loadInstr ptr)+ (var, s3) <- doExpr ty' (MExpr meta $ mkLoad atomic ptr align) return (var, s1 `snocOL` s2 `snocOL` s3, []) @@ -1845,44 +1855,62 @@ False -> do let pty = pLift ty' (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty- (var, s4) <- doExpr ty' (MExpr meta $ loadInstr ptr')+ (var, s4) <- doExpr ty' (MExpr meta $ mkLoad atomic ptr' align) return (var, s1 `snocOL` s2 `snocOL` s3 `snocOL` s4, []) -- If its a bit type then we use the slow method since -- we can't avoid casting anyway.- False -> genLoad_slow atomic e ty meta- where- loadInstr ptr | atomic = ALoad SyncSeqCst False ptr- | otherwise = Load ptr+ False -> genLoad_slow atomic e ty align meta -- | Handle Cmm load expression. -- Generic case. Uses casts and pointer arithmetic if needed.-genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData-genLoad_slow atomic e ty meta = do+genLoad_slow :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> [MetaAnnot]+ -> LlvmM ExprData+genLoad_slow atomic e ty align meta = do platform <- getPlatform cfg <- getConfig runExprData $ do iptr <- exprToVarW e case getVarType iptr of LMPointer _ ->- doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr iptr)+ doExprW (cmmToLlvmType ty) (MExpr meta $ mkLoad atomic iptr align) 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)+ doExprW (cmmToLlvmType ty) (MExpr meta $ mkLoad atomic ptr align) 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: " ++ renderWithContext (llvmCgContext cfg) (ppVar cfg iptr)))- where- loadInstr ptr | atomic = ALoad SyncSeqCst False ptr- | otherwise = Load ptr +{-+Note [Alignment of vector-typed values]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+On x86, vector types need to be 16-byte aligned for aligned+access, but we have no way of guaranteeing that this is true with GHC+(we would need to modify the layout of the stack and closures, change+the storage manager, etc.). So, we blindly tell LLVM that *any* vector+store or load could be unaligned. In the future we may be able to+guarantee that certain vector access patterns are aligned, in which+case we will need a more granular way of specifying alignment.+-} +mkLoad :: Atomic -> LlvmVar -> AlignmentSpec -> LlvmExpression+mkLoad atomic vptr alignment+ | atomic = ALoad SyncSeqCst False vptr+ | otherwise = Load vptr align+ where+ ty = pLower (getVarType vptr)+ align = case alignment of+ -- See Note [Alignment of vector-typed values]+ _ | isVector ty -> Just 1+ Unaligned -> Just 1+ NaturallyAligned -> Nothing+ -- | Handle CmmReg expression. This will return a pointer to the stack -- location of the register. Throws an error if it isn't allocated on -- the stack.@@ -1920,7 +1948,7 @@ where loadFromStack = do ptr <- getCmmReg reg let ty = pLower $ getVarType ptr- (v, s) <- doExpr ty (Load ptr)+ (v, s) <- doExpr ty (Load ptr Nothing) return (v, ty, unitOL s) -- | Allocate a local CmmReg on the stack@@ -2047,7 +2075,7 @@ rval = if isLive r then arg else trash alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 markStackReg r- return $ toOL [alloc, Store rval reg]+ return $ toOL [alloc, Store rval reg Nothing] return (concatOL stmtss `snocOL` jumpToEntry, []) where@@ -2211,8 +2239,8 @@ getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM LlvmVar getCmmRegW = lift . getCmmReg -genLoadW :: Atomic -> CmmExpr -> CmmType -> WriterT LlvmAccum LlvmM LlvmVar-genLoadW atomic e ty = liftExprData $ genLoad atomic e ty+genLoadW :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> WriterT LlvmAccum LlvmM LlvmVar+genLoadW atomic e ty alignment = liftExprData $ genLoad atomic e ty alignment -- | Return element of single-element list; 'panic' if list is not a single-element list singletonPanic :: String -> [a] -> a
compiler/GHC/CmmToLlvm/Config.hs view
@@ -26,6 +26,6 @@ , llvmCgDoWarn :: !Bool -- ^ True ==> warn unsupported Llvm version , llvmCgLlvmTarget :: !String -- ^ target triple passed to LLVM , llvmCgLlvmConfig :: !LlvmConfig -- ^ mirror DynFlags LlvmConfig.- -- see Note [LLVM Configuration] in "GHC.SysTools". This can be strict since+ -- see Note [LLVM configuration] in "GHC.SysTools". This can be strict since -- GHC.Driver.Config.CmmToLlvm.initLlvmCgConfig verifies the files are present. }
compiler/GHC/CmmToLlvm/Data.hs view
@@ -41,7 +41,7 @@ -- | Pass a CmmStatic section to an equivalent Llvm code. genLlvmData :: (Section, RawCmmStatics) -> LlvmM LlvmData--- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".+-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". genLlvmData (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l
+ compiler/GHC/Core/LateCC.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE TupleSections #-}++-- | Adds cost-centers after the core piple has run.+module GHC.Core.LateCC+ ( addLateCostCentres+ ) where++import Control.Applicative+import GHC.Utils.Monad.State.Strict+import Control.Monad++import GHC.Prelude+import GHC.Driver.Session+import GHC.Types.CostCentre+import GHC.Types.CostCentre.State+import GHC.Types.Name hiding (varName)+import GHC.Types.Tickish+import GHC.Unit.Module.ModGuts+import GHC.Types.Var+import GHC.Unit.Types+import GHC.Data.FastString+import GHC.Core+import GHC.Core.Opt.Monad+import GHC.Types.Id+import GHC.Core.Utils (mkTick)++addLateCostCentres :: ModGuts -> CoreM ModGuts+addLateCostCentres guts = do+ dflags <- getDynFlags+ let env :: Env+ env = Env+ { thisModule = mg_module guts+ , ccState = newCostCentreState+ , dflags = dflags+ }+ let guts' = guts { mg_binds = doCoreProgram env (mg_binds guts)+ }+ return guts'++doCoreProgram :: Env -> CoreProgram -> CoreProgram+doCoreProgram env binds = flip evalState newCostCentreState $ do+ mapM (doBind env) binds++doBind :: Env -> CoreBind -> M CoreBind+doBind env (NonRec b rhs) = NonRec b <$> doBndr env b rhs+doBind env (Rec bs) = Rec <$> mapM doPair bs+ where+ doPair :: ((Id, CoreExpr) -> M (Id, CoreExpr))+ doPair (b,rhs) = (b,) <$> doBndr env b rhs++doBndr :: Env -> Id -> CoreExpr -> M CoreExpr+doBndr env bndr rhs = do+ let name = idName bndr+ name_loc = nameSrcSpan name+ cc_name = getOccFS name+ count = gopt Opt_ProfCountEntries (dflags env)+ cc_flavour <- getCCExprFlavour cc_name+ let cc_mod = thisModule env+ bndrCC = NormalCC cc_flavour cc_name cc_mod name_loc+ note = ProfNote bndrCC count True+ return $ mkTick note rhs++type M = State CostCentreState++getCCExprFlavour :: FastString -> M CCFlavour+getCCExprFlavour name = ExprCC <$> getCCIndex' name++getCCIndex' :: FastString -> M CostCentreIndex+getCCIndex' name = state (getCCIndex name)++data Env = Env+ { thisModule :: Module+ , dflags :: DynFlags+ , ccState :: CostCentreState+ }+
compiler/GHC/Core/Opt/CSE.hs view
@@ -435,8 +435,8 @@ -- Extend the CSE env with a mapping [rhs -> out-id] -- unless we can instead just substitute [in-id -> rhs] ----- It's possible for the binder to be a type variable (see--- Note [Type-let] in GHC.Core), in which case we can just substitute.+-- It's possible for the binder to be a type variable,+-- in which case we can just substitute. addBinding env in_id out_id rhs' cse_done | not (isId in_id) = (extendCSSubst env in_id rhs', out_id) | noCSE in_id = (env, out_id)
compiler/GHC/Core/Opt/CallArity.hs view
@@ -99,7 +99,7 @@ the information about what variables are being called once or multiple times. Note [Analysis I: The arity analysis]-------------------------------------+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The arity analysis is quite straightforward: The information about an expression is an@@ -115,7 +115,7 @@ Note [Analysis II: The Co-Called analysis]-------------------------------------------+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The second part is more sophisticated. For reasons explained below, it is not sufficient to simply know how often an expression evaluates a variable. Instead@@ -170,7 +170,7 @@ Tricky. We assume that it is really mutually recursive, i.e. that every variable calls one of the others, and that this is strongly connected (otherwise we- return an over-approximation, so that's ok), see note [Recursion and fixpointing].+ return an over-approximation, so that's ok), see Note [Recursion and fixpointing]. Let V = {v₁,...vₙ}. Assume that the vs have been analysed with an incoming demand and@@ -438,7 +438,7 @@ where (_, binds') = callArityTopLvl [] emptyVarSet binds --- See Note [Analysing top-level-binds]+-- See Note [Analysing top-level binds] callArityTopLvl :: [Var] -> VarSet -> [CoreBind] -> (CallArityRes, [CoreBind]) callArityTopLvl exported _ [] = ( calledMultipleTimes $ (emptyUnVarGraph, mkVarEnv $ [(v, 0) | v <- exported])@@ -567,7 +567,7 @@ -- (vcat [ppr v, ppr ae_body, ppr int, ppr ae_rhs, ppr safe_arity]) (final_ae, NonRec v' rhs') where- is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk]+ is_thunk = not (exprIsCheap rhs) -- see Note [What is a thunk] -- If v is boring, we will not find it in ae_body, but always assume (0, False) boring = v `elemVarSet` boring_vars @@ -637,7 +637,7 @@ | otherwise -- We previously analyzed this with a different arity (or not at all)- = let is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk]+ = let is_thunk = not (exprIsCheap rhs) -- see Note [What is a thunk] safe_arity | is_thunk = 0 -- See Note [Thunks in recursive groups] | otherwise = new_arity
compiler/GHC/Core/Opt/CprAnal.hs view
@@ -179,7 +179,7 @@ let env = emptyAnalEnv fam_envs let binds_plus_cpr = snd $ mapAccumL cprAnalTopBind env binds putDumpFileMaybe logger Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $- dumpIdInfoOfProgram (ppr . cprSigInfo) binds_plus_cpr+ dumpIdInfoOfProgram False (ppr . cprSigInfo) binds_plus_cpr -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal seqBinds binds_plus_cpr `seq` return binds_plus_cpr
compiler/GHC/Core/Opt/DmdAnal.hs view
@@ -31,6 +31,7 @@ import GHC.Core.Utils import GHC.Core.TyCon import GHC.Core.Type+import GHC.Core.Predicate ( isClassPred ) import GHC.Core.FVs ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds ) import GHC.Core.Coercion ( Coercion ) import GHC.Core.TyCo.FVs ( coVarsOfCos )@@ -39,7 +40,7 @@ import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Panic.Plain-import GHC.Data.Maybe ( isJust )+import GHC.Data.Maybe ( isJust, orElse ) import GHC.Builtin.PrimOps import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) import GHC.Types.Unique.Set@@ -57,8 +58,9 @@ -- | Options for the demand analysis data DmdAnalOpts = DmdAnalOpts- { dmd_strict_dicts :: !Bool -- ^ Use strict dictionaries- , dmd_unbox_width :: !Int -- ^ Use strict dictionaries+ { dmd_strict_dicts :: !Bool -- ^ Use strict dictionaries+ , dmd_unbox_width :: !Int -- ^ Use strict dictionaries+ , dmd_max_worker_args :: !Int } -- This is a strict alternative to (,)@@ -278,8 +280,9 @@ where WithDmdType body_ty body' = anal_body env WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id- -- See Note [Finalising boxity for demand signature] in "GHC.Core.Opt.WorkWrap.Utils"- id_dmd' = finaliseBoxity (ae_fam_envs env) NotInsideInlineableFun (idType id) id_dmd+ -- See Note [Finalising boxity for demand signatures]++ id_dmd' = finaliseLetBoxity (ae_fam_envs env) (idType id) id_dmd !id' = setBindIdDemandInfo top_lvl id id_dmd' (rhs_ty, rhs') = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd') rhs @@ -867,7 +870,7 @@ -- See Note [NOINLINE and strictness] dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr sig $$ ppr lazy_fv) $- (env', lazy_fv, id', rhs')+ (final_env, lazy_fv, final_id, final_rhs) where rhs_arity = idArity id -- See Note [Demand signatures are computed for a threshold demand based on idArity]@@ -885,13 +888,15 @@ = unboxedWhenSmall (ae_opts env) (unboxableResultWidth env id) topSubDmd -- See Note [Do not unbox class dictionaries]- WithDmdType rhs_dmd_ty rhs' = dmdAnal (adjustInlFun id env) rhs_dmd rhs- DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty+ WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs+ DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty+ (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id rhs_arity rhs'+ `orElse` (rhs_dmds, rhs') - sig = mkDmdSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div)+ sig = mkDmdSigForArity rhs_arity (DmdType sig_fv final_rhs_dmds rhs_div) - id' = id `setIdDmdSig` sig- !env' = extendAnalEnv top_lvl env id' sig+ final_id = id `setIdDmdSig` sig+ !final_env = extendAnalEnv top_lvl env final_id sig -- See Note [Aggregated demand for cardinality] -- FIXME: That Note doesn't explain the following lines at all. The reason@@ -1156,6 +1161,371 @@ {- ********************************************************************* * *+ Finalising boxity+* *+********************************************************************* -}++{- Note [Finalising boxity for demand signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The worker/wrapper pass must strictly adhere to the boxity decisions+encoded in the demand signature, because that is the information that+demand analysis propagates throughout the program. Failing to+implement the strategy laid out in the signature can result in+reboxing in unexpected places. Hence, we must completely anticipate+unboxing decisions during demand analysis and reflect these decicions+in demand annotations. That is the job of 'finaliseArgBoxities',+which is defined here and called from demand analysis.++Here is a list of different Notes it has to take care of:++ * Note [No lazy, Unboxed demands in demand signature] such as `L!P(L)` in+ general, but still allow Note [Unboxing evaluated arguments]+ * Note [No nested Unboxed inside Boxed in demand signature] such as `1P(1!L)`+ * Implement fixes for corner cases Note [Do not unbox class dictionaries]+ and Note [mkWWstr and unsafeCoerce]++Then, in worker/wrapper blindly trusts the boxity info in the demand signature+and will not look at strictness info *at all*, in 'wantToUnboxArg'.++Note [Finalising boxity for let-bound Ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+ let x = e in body+where the demand on 'x' is 1!P(blah). We want to unbox x according to+Note [Thunk splitting] in GHC.Core.Opt.WorkWrap. We must do this becuase+worker/wrapper ignores stricness and looks only at boxity flags; so if+x's demand is L!P(blah) we might still split it (wrongly). We want to+switch to Boxed on any lazy demand.++That is what finaliseLetBoxity does. It has no worker-arg budget, so it+is much simpler than finaliseArgBoxities.++Note [No nested Unboxed inside Boxed in demand signature]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+```+f p@(x,y)+ | even (x+y) = []+ | otherwise = [p]+```+Demand analysis will infer that the function body puts a demand of `1P(1!L,1!L)`+on 'p', e.g., Boxed on the outside but Unboxed on the inside. But worker/wrapper+can't unbox the pair components without unboxing the pair! So we better say+`1P(1L,1L)` in the demand signature in order not to spread wrong Boxity info.+That happens via the call to trimBoxity in 'finaliseArgBoxities'/'finaliseLetBoxity'.++Note [No lazy, Unboxed demands in demand signature]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider T19407:++ data Huge = Huge Bool () ... () -- think: DynFlags+ data T = T { h :: Huge, n :: Int }+ f t@(T h _) = g h t+ g (H b _ ... _) t = if b then 1 else n t++The body of `g` puts (approx.) demand `L!P(A,1)` on `t`. But we better+not put that demand in `g`'s demand signature, because worker/wrapper will not+in general unbox a lazy-and-unboxed demand like `L!P(..)`.+(The exception are known-to-be-evaluated arguments like strict fields,+see Note [Unboxing evaluated arguments].)++The program above is an example where spreading misinformed boxity through the+signature is particularly egregious. If we give `g` that signature, then `f`+puts demand `S!P(1!P(1L,A,..),ML)` on `t`. Now we will unbox `t` in `f` it and+we get++ f (T (H b _ ... _) n) = $wf b n+ $wf b n = $wg b (T (H b x ... x) n)+ $wg = ...++Massive reboxing in `$wf`! Solution: Trim boxity on lazy demands in+'trimBoxity', modulo Note [Unboxing evaluated arguments].++Note [Unboxing evaluated arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this program (due to Roman):++ data X a = X !a++ foo :: X Int -> Int -> Int+ foo x@(X a) n = go 0+ where+ go i | i < n = a + go (i+1)+ | otherwise = 0++We want the worker for 'foo' to look like this:++ $wfoo :: Int# -> Int# -> Int#++with the first argument unboxed, so that it is not eval'd each time around the+'go' loop (which would otherwise happen, since 'foo' is not strict in 'a'). It+is sound for the wrapper to pass an unboxed arg because X is strict+(see Note [Strictness and Unboxing] in "GHC.Core.Opt.DmdAnal"), so its argument+must be evaluated. And if we *don't* pass an unboxed argument, we can't even+repair it by adding a `seq` thus:++ foo (X a) n = a `seq` go 0++because the seq is discarded (very early) since X is strict!++So here's what we do++* Since this has nothing to do with how 'foo' uses 'a', we leave demand+ analysis alone, but account for the additional evaluatedness when+ annotating the binder 'finaliseArgBoxities', which will retain the Unboxed+ boxity on 'a' in the definition of 'foo' in the demand 'L!P(L)'; meaning+ it's used lazily but unboxed nonetheless. This seems to contradict Note+ [No lazy, Unboxed demands in demand signature], but we know that 'a' is+ evaluated and thus can be unboxed.++* When 'finaliseArgBoxities' decides to unbox a record, it will zip the field demands+ together with the respective 'StrictnessMark'. In case of 'x', it will pair+ up the lazy field demand 'L!P(L)' on 'a' with 'MarkedStrict' to account for+ the strict field.++* Said 'StrictnessMark' is passed to the recursive invocation of 'go_args' in+ 'finaliseArgBoxities' when deciding whether to unbox 'a'. 'a' was used lazily, but+ since it also says 'MarkedStrict', we'll retain the 'Unboxed' boxity on 'a'.++* Worker/wrapper will consult 'wantToUnboxArg' for its unboxing decision. It will+ /not/ look at the strictness bits of the demand, only at Boxity flags. As such,+ it will happily unbox 'a' despite the lazy demand on it.++The net effect is that boxity analysis and the w/w transformation are more+aggressive about unboxing the strict arguments of a data constructor than when+looking at strictness info exclusively. It is very much like (Nested) CPR, which+needs its nested fields to be evaluated in order for it to unbox nestedly.++There is the usual danger of reboxing, which as usual we ignore. But+if X is monomorphic, and has an UNPACK pragma, then this optimisation+is even more important. We don't want the wrapper to rebox an unboxed+argument, and pass an Int to $wfoo!++This works in nested situations like T10482++ data family Bar a+ data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)+ newtype instance Bar Int = Bar Int++ foo :: Bar ((Int, Int), Int) -> Int -> Int+ foo f k = case f of BarPair x y ->+ case burble of+ True -> case x of+ BarPair p q -> ...+ False -> ...++The extra eagerness lets us produce a worker of type:+ $wfoo :: Int# -> Int# -> Int# -> Int -> Int+ $wfoo p# q# y# = ...++even though the `case x` is only lazily evaluated.++--------- Historical note ------------+We used to add data-con strictness demands when demand analysing case+expression. However, it was noticed in #15696 that this misses some cases. For+instance, consider the program (from T10482)++ data family Bar a+ data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)+ newtype instance Bar Int = Bar Int++ foo :: Bar ((Int, Int), Int) -> Int -> Int+ foo f k =+ case f of+ BarPair x y -> case burble of+ True -> case x of+ BarPair p q -> ...+ False -> ...++We really should be able to assume that `p` is already evaluated since it came+from a strict field of BarPair. This strictness would allow us to produce a+worker of type:++ $wfoo :: Int# -> Int# -> Int# -> Int -> Int+ $wfoo p# q# y# = ...++even though the `case x` is only lazily evaluated++Indeed before we fixed #15696 this would happen since we would float the inner+`case x` through the `case burble` to get:++ foo f k =+ case f of+ BarPair x y -> case x of+ BarPair p q -> case burble of+ True -> ...+ False -> ...++However, after fixing #15696 this could no longer happen (for the reasons+discussed in ticket:15696#comment:76). This means that the demand placed on `f`+would then be significantly weaker (since the False branch of the case on+`burble` is not strict in `p` or `q`).++Consequently, we now instead account for data-con strictness in mkWWstr_one,+applying the strictness demands to the final result of DmdAnal. The result is+that we get the strict demand signature we wanted even if we can't float+the case on `x` up through the case on `burble`.++Note [Do not unbox class dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+ f :: Ord a => [a] -> Int -> a+ {-# INLINABLE f #-}+and we worker/wrapper f, we'll get a worker with an INLINABLE pragma+(see Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap),+which can still be specialised by the type-class specialiser, something like+ fw :: Ord a => [a] -> Int# -> a++BUT if f is strict in the Ord dictionary, we might unpack it, to get+ fw :: (a->a->Bool) -> [a] -> Int# -> a+and the type-class specialiser can't specialise that. An example is #6056.++But in any other situation, a dictionary is just an ordinary value,+and can be unpacked. So we track the INLINABLE pragma, and discard the boxity+flag in finaliseArgBoxities (see the isClassPred test).++Historical note: #14955 describes how I got this fix wrong the first time.++Note that the simplicity of this fix implies that INLINE functions (such as+wrapper functions after the WW run) will never say that they unbox class+dictionaries. That's not ideal, but not worth losing sleep over, as INLINE+functions will have been inlined by the time we run demand analysis so we'll+see the unboxing around the worker in client modules. I got aware of the issue+in T5075 by the change in boxity of loop between demand analysis runs.++Note [Worker argument budget]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In 'finaliseArgBoxities' we don't want to generate workers with zillions of+argument when, say given a strict record with zillions of fields. So we+limit the maximum number of worker args to the maximum of+ - -fmax-worker-args=N+ - The number of args in the original function; if it already has has+ zillions of arguments we don't want to seek /fewer/ args in the worker.+(Maybe we should /add/ them instead of maxing?)++We pursue a "layered" strategy for unboxing: we unbox the top level of the+argument(s), subject to budget; if there are any arguments left we unbox the+next layer, using that depleted budget.++To achieve this, we use the classic almost-circular programming technique in+which we we write one pass that takes a lazy list of the Budgets for every+layer.+-}++data Budgets = MkB Arity Budgets -- An infinite list of arity budgets++incTopBudget :: Budgets -> Budgets+incTopBudget (MkB n bg) = MkB (n+1) bg++positiveTopBudget :: Budgets -> Bool+positiveTopBudget (MkB n _) = n >= 0++finaliseArgBoxities :: AnalEnv -> Id -> Arity -> CoreExpr+ -> Maybe ([Demand], CoreExpr)+finaliseArgBoxities env fn arity rhs+ | arity > count isId bndrs -- Can't find enough binders+ = Nothing -- This happens if we have f = g+ -- Then there are no binders; we don't worker/wrapper; and we+ -- simply want to give f the same demand signature as g++ | otherwise+ = Just (arg_dmds', add_demands arg_dmds' rhs)+ -- add_demands: we must attach the final boxities to the lambda-binders+ -- of the function, both because that's kosher, and because CPR analysis+ -- uses the info on the binders directly.+ where+ opts = ae_opts env+ fam_envs = ae_fam_envs env+ is_inlinable_fn = isStableUnfolding (realIdUnfolding fn)+ (bndrs, _body) = collectBinders rhs+ max_wkr_args = dmd_max_worker_args opts `max` arity+ -- See Note [Worker argument budget]++ -- This is the key line, which uses almost-circular programming+ -- The remaining budget from one layer becomes the initial+ -- budget for the next layer down. See Note [Worker argument budget]+ (remaining_budget, arg_dmds') = go_args (MkB max_wkr_args remaining_budget) arg_triples++ arg_triples :: [(Type, StrictnessMark, Demand)]+ arg_triples = take arity $+ map mk_triple $+ filter isRuntimeVar bndrs++ mk_triple :: Id -> (Type,StrictnessMark,Demand)+ mk_triple bndr | is_cls_arg ty = (ty, NotMarkedStrict, trimBoxity dmd)+ | otherwise = (ty, NotMarkedStrict, dmd)+ where+ ty = idType bndr+ dmd = idDemandInfo bndr++ -- is_cls_arg: see Note [Do not unbox class dictionaries]+ is_cls_arg arg_ty = is_inlinable_fn && isClassPred arg_ty++ go_args :: Budgets -> [(Type,StrictnessMark,Demand)] -> (Budgets, [Demand])+ go_args bg triples = mapAccumL go_arg bg triples++ go_arg :: Budgets -> (Type,StrictnessMark,Demand) -> (Budgets, Demand)+ go_arg bg@(MkB bg_top bg_inner) (ty, str_mark, dmd@(n :* _))+ = case wantToUnboxArg False fam_envs ty dmd of+ DropAbsent -> (bg, dmd)+ StopUnboxing -> (MkB (bg_top-1) bg_inner, trimBoxity dmd)++ Unbox DataConPatContext{dcpc_dc=dc, dcpc_tc_args=tc_args} dmds+ -> (MkB (bg_top-1) final_bg_inner, final_dmd)+ where+ dc_arity = dataConRepArity dc+ arg_tys = dubiousDataConInstArgTys dc tc_args+ (bg_inner', dmds') = go_args (incTopBudget bg_inner) $+ zip3 arg_tys (dataConRepStrictness dc) dmds+ dmd' = n :* (mkProd Unboxed $! dmds')+ (final_bg_inner, final_dmd)+ | dmds `lengthIs` dc_arity+ , isStrict n || isMarkedStrict str_mark+ -- isStrict: see Note [No lazy, Unboxed demands in demand signature]+ -- isMarkedStrict: see Note [Unboxing evaluated arguments]+ , positiveTopBudget bg_inner'+ = (bg_inner', dmd')+ | otherwise+ = (bg_inner, trimBoxity dmd)+ Unlift -> panic "No unlifting in DmdAnal"++ add_demands :: [Demand] -> CoreExpr -> CoreExpr+ -- Attach the demands to the outer lambdas of this expression+ add_demands [] e = e+ add_demands (dmd:dmds) (Lam v e)+ | isTyVar v = Lam v (add_demands (dmd:dmds) e)+ | otherwise = Lam (v `setIdDemandInfo` dmd) (add_demands dmds e)+ add_demands dmds e = pprPanic "add_demands" (ppr dmds $$ ppr e)++finaliseLetBoxity+ :: FamInstEnvs+ -> Type -- ^ Type of the let-bound Id+ -> Demand -- ^ How the Id is used+ -> Demand+-- See Note [Finalising boxity for let-bound Ids]+-- This function is like finaliseArgBoxities, but much simpler because+-- it has no "budget". It simply unboxes strict demands, and stops+-- when it reaches a lazy one.+finaliseLetBoxity env ty dmd+ = go ty NotMarkedStrict dmd+ where+ go ty mark dmd@(n :* _) =+ case wantToUnboxArg False env ty dmd of+ DropAbsent -> dmd+ StopUnboxing -> trimBoxity dmd+ Unbox DataConPatContext{dcpc_dc=dc, dcpc_tc_args=tc_args} dmds+ | isStrict n || isMarkedStrict mark+ , dmds `lengthIs` dataConRepArity dc+ , let arg_tys = dubiousDataConInstArgTys dc tc_args+ dmds' = strictZipWith3 go arg_tys (dataConRepStrictness dc) dmds+ -> n :* (mkProd Unboxed $! dmds')+ | otherwise+ -> trimBoxity dmd+ Unlift -> panic "No unlifting in DmdAnal"+++{- *********************************************************************+* * Fixpoints * * ********************************************************************* -}@@ -1366,11 +1736,8 @@ -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $ WithDmdType main_ty new_id where- -- See Note [Finalising boxity for demand signature] in "GHC.Core.Opt.WorkWrap.Utils"- -- and Note [Do not unbox class dictionaries]- dmd' = finaliseBoxity (ae_fam_envs env) (ae_inl_fun env) (idType id) dmd- new_id = setIdDemandInfo id dmd'- main_ty = addDemand dmd' dmd_ty'+ new_id = setIdDemandInfo id dmd+ main_ty = addDemand dmd dmd_ty' WithDmdType dmd_ty' dmd = findBndrDmd env dmd_ty id {- Note [NOINLINE and strictness]@@ -1455,9 +1822,6 @@ , ae_virgin :: !Bool -- ^ True on first iteration only -- See Note [Initialising strictness] , ae_fam_envs :: !FamInstEnvs- , ae_inl_fun :: !InsideInlineableFun- -- ^ Whether we analyse the body of an inlineable fun.- -- See Note [Do not unbox class dictionaries]. } -- We use the se_env to tell us whether to@@ -1481,7 +1845,6 @@ , ae_sigs = emptySigEnv , ae_virgin = True , ae_fam_envs = fam_envs- , ae_inl_fun = NotInsideInlineableFun } emptySigEnv :: SigEnv@@ -1509,13 +1872,6 @@ nonVirgin :: AnalEnv -> AnalEnv nonVirgin env = env { ae_virgin = False } --- | Sets 'ae_inl_fun' according to whether the given 'Id' has an inlineable--- unfolding. See Note [Do not unbox class dictionaries].-adjustInlFun :: Id -> AnalEnv -> AnalEnv-adjustInlFun id env- | isStableUnfolding (realIdUnfolding id) = env { ae_inl_fun = InsideInlineableFun }- | otherwise = env { ae_inl_fun = NotInsideInlineableFun }- findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand] -- Return the demands on the Ids in the [Var] findBndrsDmds env dmd_ty bndrs@@ -1590,8 +1946,7 @@ Which *usually* performs better. However if the dictionary is known we are far more likely to inline a function applied to the dictionary than to inline one applied to a function. Sometimes this makes just enough-of a difference to stop a function from inlining. This is documented in-#18421.+of a difference to stop a function from inlining. This is documented in #18421. It's somewhat similar to Note [Do not unbox class dictionaries] although here our problem is with the inliner, not the specializer.
compiler/GHC/Core/Opt/Exitify.hs view
@@ -310,7 +310,7 @@ Expressions are interesting when they move an occurrence of a variable outside the recursive `go` that can benefit from being obviously called once, for example:- * a local thunk that can then be inlined (see example in note [Exitification])+ * a local thunk that can then be inlined (see example in Note [Exitification]) * the parameter of a function, where the demand analyzer then can then see that it is called at most once, and hence improve the function’s strictness signature
compiler/GHC/Core/Opt/FloatIn.hs view
@@ -353,7 +353,7 @@ things to drop in the outer let's body, and let nature take its course. -Note [extra_fvs (1): avoid floating into RHS]+Note [extra_fvs (1)]: avoid floating into RHS ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider let x=\y....t... in body. We do not necessarily want to float a binding for t into the RHS, because it'll immediately be floated out@@ -371,7 +371,7 @@ So we make "extra_fvs" which is the rhs_fvs of such bindings, and arrange to dump bindings that bind extra_fvs before the entire let. -Note [extra_fvs (2): free variables of rules]+Note [extra_fvs (2)]: free variables of rules ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider let x{rule mentioning y} = rhs in body@@ -504,7 +504,7 @@ fiBind platform to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs = ( extra_binds ++ shared_binds -- Land these before- -- See Note [extra_fvs (1,2)]+ -- See Note [extra_fvs (1)] and Note [extra_fvs (2)] , FB (unitDVarSet id) rhs_fvs' -- The new binding itself (FloatLet (NonRec id rhs')) , body_binds ) -- Land these after@@ -512,12 +512,12 @@ where body_fvs2 = body_fvs `delDVarSet` id - rule_fvs = bndrRuleAndUnfoldingVarsDSet id -- See Note [extra_fvs (2): free variables of rules]+ rule_fvs = bndrRuleAndUnfoldingVarsDSet id -- See Note [extra_fvs (2)] extra_fvs | noFloatIntoRhs NonRecursive id rhs = rule_fvs `unionDVarSet` rhs_fvs | otherwise = rule_fvs- -- See Note [extra_fvs (1): avoid floating into RHS]+ -- See Note [extra_fvs (1)] -- No point in floating in only to float straight out again -- We *can't* float into ok-for-speculation unlifted RHSs -- But do float into join points@@ -541,7 +541,7 @@ (ids, rhss) = unzip bindings rhss_fvs = map freeVarsOf rhss - -- See Note [extra_fvs (1,2)]+ -- See Note [extra_fvs (1)] and Note [extra_fvs (2)] rule_fvs = mapUnionDVarSet bndrRuleAndUnfoldingVarsDSet ids extra_fvs = rule_fvs `unionDVarSet` unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings@@ -601,7 +601,7 @@ || all isTyVar (bndr:bndrs) -- Wrinkle 1 (b) -- See Note [noFloatInto considerations] wrinkle 2 - | otherwise -- Note [noFloatInto considerations] wrinkle 2+ | otherwise -- See Note [noFloatInto considerations] wrinkle 2 = exprIsTrivial deann_expr || exprIsHNF deann_expr where deann_expr = deAnnotate' expr@@ -742,7 +742,6 @@ {- Note [Duplicating floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~- For case expressions we duplicate the binding if it is reasonably small, and if it is not used in all the RHSs This is good for situations like
compiler/GHC/Core/Opt/FloatOut.hs view
@@ -280,7 +280,7 @@ -- non-rec installUnderLambdas :: Bag FloatBind -> CoreExpr -> CoreExpr--- Note [Floating out of Rec rhss]+-- See Note [Floating out of Rec rhss] installUnderLambdas floats e | isEmptyBag floats = e | otherwise = go e@@ -374,7 +374,6 @@ {- Note [Floating past breakpoints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- We used to disallow floating out of breakpoint ticks (see #10052). However, I think this is too restrictive. @@ -428,7 +427,7 @@ in (fs, annotated_defns, Tick tickish expr') } - -- Note [Floating past breakpoints]+ -- See Note [Floating past breakpoints] | Breakpoint{} <- tickish = case (floatExpr expr) of { (fs, floating_defns, expr') -> (fs, floating_defns, Tick tickish expr') }
compiler/GHC/Core/Opt/LiberateCase.hs view
@@ -168,7 +168,7 @@ ok_pair (id,_) = idArity id > 0 -- Note [Only functions!]- && not (isDeadEndId id) -- Note [Not bottoming ids]+ && not (isDeadEndId id) -- Note [Not bottoming Ids] {- Note [Not bottoming Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Core/Opt/Pipeline.hs view
@@ -17,7 +17,7 @@ import GHC.Core import GHC.Core.Opt.CSE ( cseProgram )-import GHC.Core.Rules ( mkRuleBase, unionRuleBase,+import GHC.Core.Rules ( mkRuleBase, extendRuleBaseList, ruleCheckProgram, addRuleInfo, getRules, initRuleOpts ) import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr )@@ -43,6 +43,7 @@ import GHC.Core.Opt.Exitify ( exitifyProgram ) import GHC.Core.Opt.WorkWrap ( wwTopBinds ) import GHC.Core.Opt.CallerCC ( addCallerCostCentres )+import GHC.Core.LateCC (addLateCostCentres) import GHC.Core.Seq (seqBinds) import GHC.Core.FamInstEnv @@ -225,6 +226,9 @@ add_caller_ccs = runWhen (profiling && not (null $ callerCcFilters dflags)) CoreAddCallerCcs + add_late_ccs =+ runWhen (profiling && gopt Opt_ProfLateCcs dflags) $ CoreAddLateCcs+ core_todo = [ -- We want to do the static argument transform before full laziness as it@@ -301,7 +305,7 @@ runWhen strictness demand_analyser, runWhen exitification CoreDoExitify,- -- See note [Placement of the exitification pass]+ -- See Note [Placement of the exitification pass] runWhen full_laziness $ CoreDoFloatOutwards FloatOutSwitches {@@ -369,7 +373,8 @@ maybe_rule_check FinalPhase, - add_caller_ccs+ add_caller_ccs,+ add_late_ccs ] -- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity.@@ -523,6 +528,9 @@ CoreAddCallerCcs -> {-# SCC "AddCallerCcs" #-} addCallerCostCentres guts + CoreAddLateCcs -> {-# SCC "AddLateCcs" #-}+ addLateCostCentres guts+ CoreDoPrintCore -> {-# SCC "PrintCore" #-} liftIO $ printCore logger (mg_binds guts) >> return guts @@ -559,7 +567,7 @@ (const ()) $ do rb <- getRuleBase vis_orphs <- getVisibleOrphanMods- let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn+ let rule_fn fn = getRules (RuleEnv [rb] vis_orphs) fn ++ (mg_rules guts) let ropts = initRuleOpts dflags liftIO $ logDumpMsg logger "Rule check"@@ -583,15 +591,14 @@ simplifyExpr hsc_env expr = withTiming logger (text "Simplify [expr]") (const ()) $ do { eps <- hscEPS hsc_env ;- ; let rule_env = mkRuleEnv (eps_rule_base eps) []- fi_env = ( eps_fam_inst_env eps+ ; let fi_env = ( eps_fam_inst_env eps , extendFamInstEnvList emptyFamInstEnv $ snd $ ic_instances $ hsc_IC hsc_env ) simpl_env = simplEnvForGHCi logger dflags ; let sz = exprSize expr - ; (expr', counts) <- initSmpl logger dflags rule_env fi_env sz $+ ; (expr', counts) <- initSmpl logger dflags (eps_rule_base <$> hscEPS hsc_env) emptyRuleEnv fi_env sz $ simplExprGently simpl_env expr ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats@@ -621,7 +628,7 @@ -- enforce that; it just simplifies the expression twice -- It's important that simplExprGently does eta reduction; see--- Note [Simplifying the left-hand side of a RULE] above. The+-- Note [Simplify rule LHS] above. The -- simplifier does indeed do eta reduction (it's in GHC.Core.Opt.Simplify.completeLam) -- but only if -O is on. @@ -718,21 +725,23 @@ FormatCore (pprCoreBindings tagged_binds); - -- Get any new rules, and extend the rule base- -- See Note [Overall plumbing for rules] in GHC.Core.Rules- -- We need to do this regularly, because simplification can+ -- read_eps_rules:+ -- We need to read rules from the EPS regularly because simplification can -- poke on IdInfo thunks, which in turn brings in new rules -- behind the scenes. Otherwise there's a danger we'll simply -- miss the rules for Ids hidden inside imported inlinings+ -- Hence just before attempting to match rules we read on the EPS+ -- value and then combine it when the existing rule base.+ -- See `GHC.Core.Opt.Simplify.Monad.getSimplRules`. eps <- hscEPS hsc_env ;- let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)- ; rule_base2 = extendRuleBaseList rule_base1 rules+ let { read_eps_rules = eps_rule_base <$> hscEPS hsc_env+ ; rule_base = extendRuleBaseList hpt_rule_base rules ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) ; vis_orphs = this_mod : dep_orphs deps } ; -- Simplify the program ((binds1, rules1), counts1) <-- initSmpl logger dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs sz $+ initSmpl logger dflags read_eps_rules (mkRuleEnv rule_base vis_orphs) fam_envs sz $ do { (floats, env1) <- {-# SCC "SimplTopBinds" #-} simplTopBinds simpl_env tagged_binds @@ -934,7 +943,7 @@ shortOutIndirections :: CoreProgram -> CoreProgram shortOutIndirections binds | isEmptyVarEnv ind_env = binds- | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping]+ | no_need_to_flatten = binds' -- See Note [Rules and indirection-zapping] | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff where ind_env = makeIndEnv binds@@ -996,7 +1005,7 @@ not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for then if hasShortableIdInfo exported_id- then True -- See Note [Messing up the exported Id's IdInfo]+ then True -- See Note [Messing up the exported Id's RULES] else warnPprTrace True "Not shorting out" (ppr exported_id) False else False@@ -1005,7 +1014,7 @@ hasShortableIdInfo :: Id -> Bool -- True if there is no user-attached IdInfo on exported_id, -- so we can safely discard it--- See Note [Messing up the exported Id's IdInfo]+-- See Note [Messing up the exported Id's RULES] hasShortableIdInfo id = isEmptyRuleInfo (ruleInfo info) && isDefaultInlinePragma (inlinePragInfo info)@@ -1065,11 +1074,12 @@ dmdAnal :: Logger -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram dmdAnal logger dflags fam_envs rules binds = do let !opts = DmdAnalOpts- { dmd_strict_dicts = gopt Opt_DictsStrict dflags- , dmd_unbox_width = dmdUnboxWidth dflags+ { dmd_strict_dicts = gopt Opt_DictsStrict dflags+ , dmd_unbox_width = dmdUnboxWidth dflags+ , dmd_max_worker_args = maxWorkerArgs dflags } binds_plus_dmds = dmdAnalProgram opts fam_envs rules binds Logger.putDumpFileMaybe logger Opt_D_dump_str_signatures "Strictness signatures" FormatText $- dumpIdInfoOfProgram (ppr . zapDmdEnvSig . dmdSigInfo) binds_plus_dmds+ dumpIdInfoOfProgram (hasPprDebug dflags) (ppr . zapDmdEnvSig . dmdSigInfo) binds_plus_dmds -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal seqBinds binds_plus_dmds `seq` return binds_plus_dmds
compiler/GHC/Core/Opt/Simplify.hs view
@@ -216,7 +216,7 @@ -- so that if a rewrite rule has unexpectedly brought -- anything into scope, then we don't get a complaint about that. -- It's rather as if the top-level binders were imported.- -- See note [Glomming] in "GHC.Core.Opt.OccurAnal".+ -- See Note [Glomming] in "GHC.Core.Opt.OccurAnal". -- See Note [Bangs in the Simplifier] ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0) ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0@@ -669,7 +669,7 @@ -- See Note [Cast worker/wrapper] mkCastWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info }) = InlinePragma { inl_src = SourceText "{-# INLINE"- , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInline]+ , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInlinePrag] , inl_sat = Nothing -- in GHC.Core.Opt.WorkWrap , inl_act = wrap_act -- See Note [Wrapper activation] , inl_rule = rule_info } -- in GHC.Core.Opt.WorkWrap@@ -1393,6 +1393,7 @@ getDoneId other = pprPanic "getDoneId" (ppr other) -- Note [case-of-scc-of-case]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ -- It's pretty important to be able to transform case-of-case when -- there's an SCC in the way. For example, the following comes up -- in nofib/real/compress/Encode.hs:@@ -1992,6 +1993,7 @@ cont' = trimJoinCont var mb_join cont in simplExprF env' e cont' -- Note [zapSubstEnv]+ -- ~~~~~~~~~~~~~~~~~~ -- The template is already simplified, so don't re-substitute. -- This is VITAL. Consider -- let x = e in@@ -2085,7 +2087,7 @@ | nr_wanted == 0 || no_more_args , let info' = info { ai_rules = Nothing } = -- We've accumulated a simplified call in <fun,rev_args>- -- so try rewrite rules; see Note [RULEs apply to simplified arguments]+ -- so try rewrite rules; see Note [RULES apply to simplified arguments] -- See also Note [Rules for recursive functions] do { mb_match <- tryRules env rules fun (reverse rev_args) cont ; case mb_match of
compiler/GHC/Core/Opt/Simplify/Monad.hs view
@@ -28,7 +28,8 @@ import GHC.Types.Id.Info ( IdDetails(..), vanillaIdInfo, setArityInfo ) import GHC.Core.Type ( Type, Mult ) import GHC.Core.FamInstEnv ( FamInstEnv )-import GHC.Core ( RuleEnv(..) )+import GHC.Core ( RuleEnv(..), RuleBase)+import GHC.Core.Rules import GHC.Core.Utils ( mkLamTypes ) import GHC.Core.Coercion.Opt import GHC.Types.Unique.Supply@@ -79,20 +80,23 @@ = STE { st_flags :: DynFlags , st_logger :: !Logger , st_max_ticks :: IntWithInf -- ^ Max #ticks in this simplifier run- , st_rules :: RuleEnv+ , st_query_rulebase :: IO RuleBase+ -- ^ The action to retrieve an up-to-date EPS RuleBase+ -- See Note [Overall plumbing for rules]+ , st_mod_rules :: RuleEnv , st_fams :: (FamInstEnv, FamInstEnv) , st_co_opt_opts :: !OptCoercionOpts -- ^ Coercion optimiser options } -initSmpl :: Logger -> DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv)+initSmpl :: Logger -> DynFlags -> IO RuleBase -> RuleEnv -> (FamInstEnv, FamInstEnv) -> Int -- Size of the bindings, used to limit -- the number of ticks we allow -> SimplM a -> IO (a, SimplCount) -initSmpl logger dflags rules fam_envs size m+initSmpl logger dflags qrb rules fam_envs size m = do -- No init count; set to 0 let simplCount = zeroSimplCount dflags (result, count) <- unSM m env simplCount@@ -100,7 +104,8 @@ where env = STE { st_flags = dflags , st_logger = logger- , st_rules = rules+ , st_query_rulebase = qrb+ , st_mod_rules = rules , st_max_ticks = computeMaxTicks dflags size , st_fams = fam_envs , st_co_opt_opts = initOptCoercionOpts dflags@@ -203,7 +208,9 @@ return (x, sc) getSimplRules :: SimplM RuleEnv-getSimplRules = SM (\st_env sc -> return (st_rules st_env, sc))+getSimplRules = SM (\st_env sc -> do+ eps_rules <- st_query_rulebase st_env+ return (extendRuleEnv (st_mod_rules st_env) eps_rules, sc)) getFamEnvs :: SimplM (FamInstEnv, FamInstEnv) getFamEnvs = SM (\st_env sc -> return (st_fams st_env, sc))@@ -215,6 +222,7 @@ newId fs w ty = do uniq <- getUniqueM return (mkSysLocalOrCoVar fs uniq w ty) +-- | Make a join id with given type and arity but without call-by-value annotations. newJoinId :: [Var] -> Type -> SimplM Id newJoinId bndrs body_ty = do { uniq <- getUniqueM@@ -223,7 +231,7 @@ arity = count isId bndrs -- arity: See Note [Invariants on join points] invariant 2b, in GHC.Core join_arity = length bndrs- details = JoinId join_arity+ details = JoinId join_arity Nothing id_info = vanillaIdInfo `setArityInfo` arity -- `setOccInfo` strongLoopBreaker
compiler/GHC/Core/Opt/Simplify/Utils.hs view
@@ -130,7 +130,7 @@ | ApplyToVal -- (ApplyToVal arg K)[e] = K[ e arg ] { sc_dup :: DupFlag -- See Note [DupFlag invariants] , sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah)- -- See Note [The hole type in ApplyToTy/Val]+ -- See Note [The hole type in ApplyToTy] , sc_arg :: InExpr -- The argument, , sc_env :: StaticEnv -- see Note [StaticEnv invariant] , sc_cont :: SimplCont }@@ -138,7 +138,7 @@ | ApplyToTy -- (ApplyToTy ty K)[e] = K[ e ty ] { sc_arg_ty :: OutType -- Argument type , sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah)- -- See Note [The hole type in ApplyToTy/Val]+ -- See Note [The hole type in ApplyToTy] , sc_cont :: SimplCont } | Select -- (Select alts K)[e] = K[ case e of alts ]@@ -453,7 +453,7 @@ = perhapsSubstTy dup se (idType b) contHoleType (StrictArg { sc_fun_ty = ty }) = funArgTy ty contHoleType (ApplyToTy { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy]-contHoleType (ApplyToVal { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy/Val]+contHoleType (ApplyToVal { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy] contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se }) = perhapsSubstTy d se (idType b) @@ -1130,13 +1130,9 @@ mode = getMode env id_unf id | unf_is_active id = idUnfolding id | otherwise = NoUnfolding- unf_is_active id- | not (sm_rules mode) = -- active_unfolding_minimal id- isStableUnfolding (realIdUnfolding id)- -- Do we even need to test this? I think this InScopeEnv- -- is only consulted if activeRule returns True, which- -- never happens if sm_rules is False- | otherwise = isActive (sm_phase mode) (idInlineActivation id)+ unf_is_active id = isActive (sm_phase mode) (idInlineActivation id)+ -- When sm_rules was off we used to test for a /stable/ unfolding,+ -- but that seems wrong (#20941) ---------------------- activeRule :: SimplMode -> Activation -> Bool@@ -1293,7 +1289,7 @@ | not (one_occ (idOccInfo bndr)) = Nothing | not (isStableUnfolding unf) = Just $! (extend_subst_with rhs) - -- Note [Stable unfoldings and preInlineUnconditionally]+ -- See Note [Stable unfoldings and preInlineUnconditionally] | not (isInlinePragma inline_prag) , Just inl <- maybeUnfoldingTemplate unf = Just $! (extend_subst_with inl) | otherwise = Nothing@@ -1395,7 +1391,7 @@ story for now. NB: unconditional inlining of this sort can introduce ticks in places that-may seem surprising; for instance, the LHS of rules. See Note [Simplfying+may seem surprising; for instance, the LHS of rules. See Note [Simplifying rules] for details. -} @@ -1625,7 +1621,7 @@ = do { tick (EtaReduction (head bndrs)) ; return etad_lam } - | not (contIsRhs cont) -- See Note [Eta-expanding lambdas]+ | not (contIsRhs cont) -- See Note [Eta expanding lambdas] , sm_eta_expand mode , any isRuntimeVar bndrs , let body_arity = {-# SCC "eta" #-} exprEtaExpandArity dflags body@@ -2196,9 +2192,9 @@ mkCase tries these things -* Note [Nerge nested cases]-* Note [Eliminate identity case]-* Note [Scrutinee constant folding]+* Note [Merge Nested Cases]+* Note [Eliminate Identity Case]+* Note [Scrutinee Constant Folding] Note [Merge Nested Cases] ~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Core/Opt/SpecConstr.hs view
@@ -656,6 +656,11 @@ We give sc_s5lZ and sc_s5m0 a evaluated unfolding since they come out of strict field fields in the Bin constructor.+This is especially important since tag inference can then use this+information to adjust the calling convention of+`$wmerge0_s4UK` to enforce arguments being passed fully evaluated+tagged.+See Note [Tag Inference], Note [Strict Worker Ids] for more information on+how we can take advantage of this. ----------------------------------------------------- Stuff not yet handled@@ -1181,8 +1186,8 @@ | ScrutOcc -- See Note [ScrutOcc] (DataConEnv [ArgOcc]) -- How the sub-components are used -{- Note [ScrutOcc]-~~~~~~~~~~~~~~~~~~~+{- Note [ScrutOcc]+~~~~~~~~~~~~~~~~~~ An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing, is *only* taken apart or applied. @@ -1316,7 +1321,7 @@ ; rhs_info <- scRecRhs env (bndr',rhs) ; let body_env2 = extendHowBound body_env [bndr'] RecFun- -- Note [Local let bindings]+ -- See Note [Local let bindings] rhs' = ri_new_rhs rhs_info body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs') @@ -1771,11 +1776,15 @@ -- Annotate the variables with the strictness information from -- the function (see Note [Strictness information in worker binders]) - (spec_lam_args, spec_call_args) = mkWorkerArgs fn False- spec_lam_args1+ (spec_lam_args, spec_call_args,_) = mkWorkerArgs fn False+ spec_lam_args1 [] spec_body_ty -- mkWorkerArgs: usual w/w hack to avoid generating -- a spec_rhs of unlifted type and no args.+ -- Unlike W/W we don't turn functions into strict workers+ -- immediately here instead letting tidy handle this.+ -- For this reason we can ignore the cbv marks.+ -- See Note [Strict Worker Ids]. See Note [Tag Inference]. spec_id = mkLocalId spec_name Many (mkLamTypes spec_lam_args spec_body_ty)
compiler/GHC/Core/Opt/Specialise.hs view
@@ -739,8 +739,7 @@ ; hsc_env <- getHscEnv ; eps <- liftIO $ hscEPS hsc_env ; vis_orphs <- getVisibleOrphanMods- ; let full_rb = unionRuleBase rb (eps_rule_base eps)- rules_for_fn = getRules (RuleEnv full_rb vis_orphs) fn+ ; let rules_for_fn = getRules (RuleEnv [rb, eps_rule_base eps] vis_orphs) fn ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls }) <- -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs]) >>@@ -809,7 +808,7 @@ tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM () -- See Note [Warning about missed specialisations] tryWarnMissingSpecs dflags callers fn calls_for_fn- | isClassOpId fn = return () -- See Note [Missed specialization for ClassOps]+ | isClassOpId fn = return () -- See Note [Missed specialisation for ClassOps] | wopt Opt_WarnMissedSpecs dflags && not (null callers) && allCallersInlined = doWarn $ WarningWithFlag Opt_WarnMissedSpecs@@ -1434,7 +1433,7 @@ -- See Note [Auto-specialisation and RULES] -- && not (certainlyWillInline (idUnfolding fn)) -- And it's not small--- See Note [Inline specialisation] for why we do not+-- See Note [Inline specialisations] for why we do not -- switch off specialisation for inline functions = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $
compiler/GHC/Core/Opt/WorkWrap.hs view
@@ -11,7 +11,6 @@ import GHC.Driver.Session -import GHC.Core.Opt.Arity ( manifestArity ) import GHC.Core import GHC.Core.Unfold.Make import GHC.Core.Utils ( exprType, exprIsHNF )@@ -552,7 +551,7 @@ | isRecordSelector fn_id = return [ (new_fn_id, rhs ) ] - | is_fun && is_eta_exp+ | is_fun = splitFun ww_opts new_fn_id rhs -- See Note [Thunk splitting]@@ -576,8 +575,6 @@ | otherwise = id -- See Note [Don't w/w join points for CPR] - -- is_eta_exp: see Note [Don't eta expand in w/w]- is_eta_exp = length wrap_dmds == manifestArity rhs is_fun = notNull wrap_dmds || isJoinId fn_id is_thunk = not is_fun && not (exprIsHNF rhs) && not (isJoinId fn_id) && not (isUnliftedType (idType fn_id))@@ -722,6 +719,11 @@ --------------------- splitFun :: WwOpts -> Id -> CoreExpr -> UniqSM [(Id, CoreExpr)] splitFun ww_opts fn_id rhs+ | not (wrap_dmds `lengthIs` count isId arg_vars)+ -- See Note [Don't eta expand in w/w]+ = return [(fn_id, rhs)]++ | otherwise = warnPprTrace (not (wrap_dmds `lengthIs` (arityInfo fn_info))) "splitFun" (ppr fn_id <+> (ppr wrap_dmds $$ ppr cpr)) $@@ -761,11 +763,12 @@ mkWWBindPair :: WwOpts -> Id -> IdInfo -> [Var] -> CoreExpr -> Unique -> Divergence- -> ([Demand], JoinArity, Id -> CoreExpr, Expr CoreBndr -> CoreExpr)+ -> ([Demand],[CbvMark], JoinArity, Id -> CoreExpr, Expr CoreBndr -> CoreExpr) -> [(Id, CoreExpr)] mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div- (work_demands, join_arity, wrap_fn, work_fn)- = [(work_id, work_rhs), (wrap_id, wrap_rhs)]+ (work_demands, cbv_marks :: [CbvMark], join_arity, wrap_fn, work_fn)+ = -- pprTrace "mkWWBindPair" (ppr fn_id <+> ppr wrap_id <+> ppr work_id $$ ppr wrap_rhs) $+ [(work_id, work_rhs), (wrap_id, wrap_rhs)] -- Worker first, because wrapper mentions it where arity = arityInfo fn_info@@ -817,11 +820,15 @@ -- Set the arity so that the Core Lint check that the -- arity is consistent with the demand type goes -- through++ `setIdCbvMarks` cbv_marks+ `asJoinId_maybe` work_join_arity+ -- `setIdThing` (undefined cbv_marks) - work_arity = length work_demands+ work_arity = length work_demands :: Int - -- See Note [Demand on the Worker]+ -- See Note [Demand on the worker] single_call = saturatedByOneShots arity (demandInfo fn_info) worker_demand | single_call = mkWorkerDemand work_arity | otherwise = topDmd@@ -845,7 +852,7 @@ -- See Note [Wrapper activation] mkStrWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info }) rules = InlinePragma { inl_src = SourceText "{-# INLINE"- , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInline]+ , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInlinePrag] , inl_sat = Nothing , inl_act = activeAfter wrapper_phase , inl_rule = rule_info } -- RuleMatchInfo is (and must be) unaffected@@ -907,41 +914,60 @@ Note [Thunk splitting] ~~~~~~~~~~~~~~~~~~~~~~-Suppose x is used strictly (never mind whether it has the CPR-property).+Suppose x is used strictly; never mind whether it has the CPR+property. I'll use a '*' to mean "x* is demanded strictly". let x* = x-rhs in body splitThunk transforms like this:- let- x* = case x-rhs of { I# a -> I# a }+ x* = let x = x-rhs in+ case x of { I# a -> I# a } in body -Now simplifier will transform to-+This is a little strange: we are re-using the same `x` in the RHS; and+the RHS takes `x` apart and reboxes it. But because the outer 'let' is+strict, and the inner let mentions `x` only once, the simplifier+transform it to case x-rhs of I# a -> let x* = I# a in body -which is what we want. Now suppose x-rhs is itself a case:-- x-rhs = case e of { T -> I# a; F -> I# b }+That is good: in `body` we know the form of `x`, which+ * gives the CPR property, and+ * allows case-of-case to happen on x -The join point will abstract over a, rather than over (which is-what would have happened before) which is fine.+Notes+* I tried transforming like this:+ let+ x* = let x = x-rhs in+ case x of { I# a -> x }+ in body+ where I return `x` itself, rather than reboxing it. But this+ turned out to cause some regressions, which I never fully+ investigated. -Notice that x certainly has the CPR property now!+* Suppose x-rhs is itself a case:+ x-rhs = case e of { T -> I# e1; F -> I# e2 }+ Then we'll get+ join j a = let x* = I# a in body+ in case e of { T -> j e1; F -> j e2 }+ which is good (no boxing). But in the original, unsplit program+ we would transform+ let x* = case e of ... in body+ ==> join j2 x = body+ in case e of { T -> j2 (I# e1); F -> j (I# e2) }+ which is not good (boxing). -In fact, splitThunk uses the function argument w/w splitting-function, so that if x's demand is deeper (say U(U(L,L),L))-then the splitting will go deeper too.+* In fact, splitThunk uses the function argument w/w splitting+ function, mkWWstr_one, so that if x's demand is deeper (say U(U(L,L),L))+ then the splitting will go deeper too. -NB: For recursive thunks, the Simplifier is unable to float `x-rhs` out of-`x*`'s RHS, because `x*` occurs freely in `x-rhs`, and will just change it-back to the original definition, so we just split non-recursive thunks.+* For recursive thunks, the Simplifier is unable to float `x-rhs` out of+ `x*`'s RHS, because `x*` occurs freely in `x-rhs`, and will just change it+ back to the original definition, so we just split non-recursive thunks. Note [Thunk splitting for top-level binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -993,7 +1019,8 @@ splitThunk ww_opts is_rec x rhs = assert (not (isJoinId x)) $ do { let x' = localiseId x -- See comment above- ; (useful,_, wrap_fn, fn_arg) <- mkWWstr_one ww_opts x'+ ; (useful,_args, wrap_fn, fn_arg)+ <- mkWWstr_one ww_opts x' NotMarkedCbv ; let res = [ (x, Let (NonRec x' rhs) (wrap_fn fn_arg)) ] ; if useful then assertPpr (isNonRec is_rec) (ppr x) -- The thunk must be non-recursive return res
compiler/GHC/Core/Opt/WorkWrap/Utils.hs view
@@ -10,10 +10,11 @@ module GHC.Core.Opt.WorkWrap.Utils ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWWstr_one, mkWorkerArgs , DataConPatContext(..)- , UnboxingDecision(..), InsideInlineableFun(..), wantToUnboxArg- , findTypeShape, IsRecDataConResult(..), isRecDataCon, finaliseBoxity+ , UnboxingDecision(..), wantToUnboxArg+ , findTypeShape, IsRecDataConResult(..), isRecDataCon , mkAbsentFiller- , isWorkerSmallEnough+ , isWorkerSmallEnough, dubiousDataConInstArgTys+ , isGoodWorker, badWorker , goodWorker ) where @@ -29,7 +30,6 @@ import GHC.Core.Subst import GHC.Core.Type import GHC.Core.Multiplicity-import GHC.Core.Predicate ( isClassPred ) import GHC.Core.Coercion import GHC.Core.Reduction import GHC.Core.FamInstEnv@@ -142,9 +142,12 @@ , wo_simple_opts :: !SimpleOpts , wo_cpr_anal :: !Bool , wo_fun_to_thunk :: !Bool- , wo_max_worker_args :: !Int+ -- Used for absent argument error message , wo_module :: !Module+ , wo_unlift_strict :: !Bool -- Generate workers even if the only effect is some args+ -- get passed unlifted.+ -- See Note [WW for calling convention] } initWwOpts :: Module -> DynFlags -> FamInstEnvs -> WwOpts@@ -153,12 +156,13 @@ , wo_simple_opts = initSimpleOpts dflags , wo_cpr_anal = gopt Opt_CprAnal dflags , wo_fun_to_thunk = gopt Opt_FunToThunk dflags- , wo_max_worker_args = maxWorkerArgs dflags , wo_module = this_mod+ , wo_unlift_strict = gopt Opt_WorkerWrapperUnlift dflags } type WwResult = ([Demand], -- Demands for worker (value) args+ [CbvMark], -- Cbv semantics for worker (value) args JoinArity, -- Number of worker (type OR value) args Id -> CoreExpr, -- Wrapper body, lacking only the worker Id CoreExpr -> CoreExpr) -- Worker body, lacking the original function rhs@@ -228,27 +232,29 @@ zapped_arg_vars = map zap_var arg_vars (subst, cloned_arg_vars) = cloneBndrs empty_subst uniq_supply zapped_arg_vars res_ty' = GHC.Core.Subst.substTy subst res_ty+ init_cbv_marks = map (const NotMarkedCbv) cloned_arg_vars - ; (useful1, work_args, wrap_fn_str, fn_args)- <- mkWWstr opts cloned_arg_vars+ ; (useful1, work_args_cbv, wrap_fn_str, fn_args)+ <- mkWWstr opts cloned_arg_vars init_cbv_marks + ; let (work_args, work_marks) = unzip work_args_cbv+ -- Do CPR w/w. See Note [Always do CPR w/w] ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty) <- mkWWcpr_entry opts res_ty' res_cpr - ; let (work_lam_args, work_call_args) = mkWorkerArgs fun_id (wo_fun_to_thunk opts)- work_args cpr_res_ty+ ; let (work_lam_args, work_call_args, work_call_cbv) = mkWorkerArgs fun_id (wo_fun_to_thunk opts)+ work_args work_marks cpr_res_ty+ call_work work_fn = mkVarApps (Var work_fn) work_call_args call_rhs fn_rhs = mkAppsBeta fn_rhs fn_args -- See Note [Join points and beta-redexes] wrapper_body = mkLams cloned_arg_vars . wrap_fn_cpr . wrap_fn_str . call_work worker_body = mkLams work_lam_args . work_fn_cpr . call_rhs- worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v]+ (worker_args_dmds, work_val_cbvs)= unzip [(idDemandInfo v,cbv) | (v,cbv) <- zipEqual "mkWwBodies" work_call_args work_call_cbv, isId v] - ; if isWorkerSmallEnough (wo_max_worker_args opts) (length demands) work_args- && not (too_many_args_for_join_point arg_vars)- && ((useful1 && not only_one_void_argument) || useful2)- then return (Just (worker_args_dmds, length work_call_args,+ ; if ((useful1 && not only_one_void_argument) || useful2)+ then return (Just (worker_args_dmds, work_val_cbvs, length work_call_args, wrapper_body, worker_body)) else return Nothing }@@ -265,8 +271,6 @@ zap_info info -- See Note [Zap IdInfo on worker args] = info `setOccInfo` noOccInfo - mb_join_arity = isJoinId_maybe fun_id- -- Note [Do not split void functions] only_one_void_argument | [d] <- demands@@ -276,17 +280,6 @@ | otherwise = False - -- Note [Join points returning functions]- too_many_args_for_join_point wrap_args- | Just join_arity <- mb_join_arity- , wrap_args `lengthExceeds` join_arity- = warnPprTrace True "Unable to worker/wrapper join point"- (text "arity" <+> int join_arity <+> text "but" <+>- int (length wrap_args) <+> text "args") $- True- | otherwise- = False- -- | Version of 'GHC.Core.mkApps' that does beta reduction on-the-fly. -- PRECONDITION: The arg expressions are not free in any of the lambdas binders. mkAppsBeta :: CoreExpr -> [CoreArg] -> CoreExpr@@ -376,20 +369,25 @@ We use the state-token type which generates no code. -} +-- | Prevent a function from becoming a thunk by adding a void argument if+-- required. mkWorkerArgs :: Id -- The wrapper Id- -> Bool+ -> Bool -- Allow fun->thunk conversion. -> [Var]+ -> [CbvMark] -> Type -- Type of body -> ([Var], -- Lambda bound args- [Var]) -- Args at call site-mkWorkerArgs wrap_id fun_to_thunk args res_ty+ [Var], -- Args at call site+ [CbvMark] -- cbv semantics for the worker args.+ )+mkWorkerArgs wrap_id fun_to_thunk args cbv_marks res_ty | not (isJoinId wrap_id) -- Join Ids never need an extra arg , not (any isId args) -- No existing value lambdas , needs_a_value_lambda -- and we need to add one- = (args ++ [voidArgId], args ++ [voidPrimId])+ = (args ++ [voidArgId], args ++ [voidPrimId], cbv_marks ++ [NotMarkedCbv]) | otherwise- = (args, args)+ = (args, args, cbv_marks) where -- If fun_to_thunk is False we always keep at least one value -- argument: see Note [Protecting the last value argument]@@ -454,36 +452,6 @@ Hence we simply do the beta-reduction here. (This would be harder if we had to worry about hygiene, but luckily wy is freshly generated.) -Note [Join points returning functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It is crucial that the arity of a join point depends on its *callers,* not its-own syntax. What this means is that a join point can have "extra lambdas":--f :: Int -> Int -> (Int, Int) -> Int-f x y = join j (z, w) = \(u, v) -> ...- in jump j (x, y)--Typically this happens with functions that are seen as computing functions,-rather than being curried. (The real-life example was GHC.Data.Graph.Ops.addConflicts.)--When we create the wrapper, it *must* be in "eta-contracted" form so that the-jump has the right number of arguments:--f x y = join $wj z' w' = \u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...- j (z, w) = jump $wj z w--(See Note [Join points and beta-redexes] for where the lets come from.) If j-were a function, we would instead say--f x y = let $wj = \z' w' u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...- j (z, w) (u, v) = $wj z w u v--Notice that the worker ends up with the same lambdas; it's only the wrapper we-have to be concerned about.--FIXME Currently the functionality to produce "eta-contracted" wrappers is-unimplemented; we simply give up.- Note [Freshen WW arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we do a worker/wrapper split, we must freshen the arg vars of the original@@ -559,28 +527,56 @@ -- instantiation with 'dataConRepInstPat'. -- The @[s]@ carries the bits of information with which we can continue -- unboxing, e.g. @s@ will be 'Demand' or 'Cpr'.+ | Unlift+ -- ^ The argument can't be unboxed, but we want it to be passed evaluated to the worker. +-- Do we want to create workers just for unlifting?+wwForUnlifting :: WwOpts -> Bool+wwForUnlifting !opts+ -- Always unlift if possible+ | wo_unlift_strict opts = goodWorker+ -- Don't unlift it would cause additional W/W splits.+ | otherwise = badWorker++badWorker :: Bool+badWorker = False++goodWorker :: Bool+goodWorker = True++isGoodWorker :: Bool -> Bool+isGoodWorker = id++ -- | Unwraps the 'Boxity' decision encoded in the given 'SubDemand' and returns -- a 'DataConPatContext' as well the nested demands on fields of the 'DataCon' -- to unbox. wantToUnboxArg- :: FamInstEnvs+ :: Bool -- ^ Consider unlifting+ -> FamInstEnvs -> Type -- ^ Type of the argument -> Demand -- ^ How the arg was used -> UnboxingDecision Demand -- See Note [Which types are unboxed?]-wantToUnboxArg fam_envs ty (n :* sd)+wantToUnboxArg do_unlifting fam_envs ty dmd@(n :* sd) | isAbs n = DropAbsent | Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty , Just dc <- tyConSingleAlgDataCon_maybe tc , let arity = dataConRepArity dc- , Just (Unboxed, ds) <- viewProd arity sd -- See Note [Boxity Analysis]- -- NB: No strictness or evaluatedness checks here. That is done by- -- 'finaliseBoxity'!+ , Just (Unboxed, ds) <- viewProd arity sd -- See Note [Boxity analysis]+ -- NB: No strictness or evaluatedness checks for unboxing here.+ -- That is done by 'finaliseArgBoxities'! = Unbox (DataConPatContext dc tc_args co) ds + -- See Note [Strict Worker Ids]+ | do_unlifting+ , isStrUsedDmd dmd+ , not (isFunTy ty)+ , not (isUnliftedType ty) -- Already unlifted!+ = Unlift+ | otherwise = StopUnboxing @@ -657,33 +653,6 @@ constraints, type classes etc. So it can be GADT. These evidence arguments are simply value arguments, and should not get in the way. -Note [Do not unbox class dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have- f :: Ord a => [a] -> Int -> a- {-# INLINABLE f #-}-and we worker/wrapper f, we'll get a worker with an INLINABLE pragma-(see Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap),-which can still be specialised by the type-class specialiser, something like- fw :: Ord a => [a] -> Int# -> a--BUT if f is strict in the Ord dictionary, we might unpack it, to get- fw :: (a->a->Bool) -> [a] -> Int# -> a-and the type-class specialiser can't specialise that. An example is #6056.--But in any other situation, a dictionary is just an ordinary value,-and can be unpacked. So we track the INLINABLE pragma, and discard the boxity-flag in finaliseBoxity (see the isClassPred test).--Historical note: #14955 describes how I got this fix wrong the first time.--Note that the simplicity of this fix implies that INLINE functions (such as-wrapper functions after the WW run) will never say that they unbox class-dictionaries. That's not ideal, but not worth losing sleep over, as INLINE-functions will have been inlined by the time we run demand analysis so we'll-see the unboxing around the worker in client modules. I got aware of the issue-in T5075 by the change in boxity of loop between demand analysis runs.- Note [mkWWstr and unsafeCoerce] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ By using unsafeCoerce, it is possible to make the number of demands fail to@@ -691,193 +660,6 @@ If so, the worker/wrapper split doesn't work right and we get a Core Lint bug. The fix here is simply to decline to do w/w if that happens. -Note [Unboxing evaluated arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this program (due to Roman):-- data X a = X !a-- foo :: X Int -> Int -> Int- foo x@(X a) n = go 0- where- go i | i < n = a + go (i+1)- | otherwise = 0--We want the worker for 'foo' too look like this:-- $wfoo :: Int# -> Int# -> Int#--with the first argument unboxed, so that it is not eval'd each time around the-'go' loop (which would otherwise happen, since 'foo' is not strict in 'a'). It-is sound for the wrapper to pass an unboxed arg because X is strict-(see Note [Strictness and Unboxing] in "GHC.Core.Opt.DmdAnal"), so its argument-must be evaluated. And if we *don't* pass an unboxed argument, we can't even-repair it by adding a `seq` thus:-- foo (X a) n = a `seq` go 0--because the seq is discarded (very early) since X is strict!--So here's what we do--* Since this has nothing to do with how 'foo' uses 'a', we leave demand analysis- alone, but account for the additional evaluatedness when annotating the binder- in 'annotateLamIdBndr' via 'finaliseBoxity', which will retain the Unboxed boxity- on 'a' in the definition of 'foo' in the demand 'L!P(L)'; meaning it's used- lazily but unboxed nonetheless. This seems to contradict- Note [No lazy, Unboxed demands in demand signature], but we know that 'a' is- evaluated and thus can be unboxed.--* When 'finaliseBoxity' decides to unbox a record, it will zip the field demands- together with the respective 'StrictnessMark'. In case of 'x', it will pair- up the lazy field demand 'L!P(L)' on 'a' with 'MarkedStrict' to account for- the strict field.--* Said 'StrictnessMark' is passed to the recursive invocation of- 'finaliseBoxity' when deciding whether to unbox 'a'. 'a' was used lazily, but- since it also says 'MarkedStrict', we'll retain the 'Unboxed' boxity on 'a'.--* Worker/wrapper will consult 'wantToUnboxArg' for its unboxing decision. It will- /not/ look at the strictness bits of the demand, only at Boxity flags. As such,- it will happily unbox 'a' despite the lazy demand on it.--The net effect is that boxity analysis and the w/w transformation are more-aggressive about unboxing the strict arguments of a data constructor than when-looking at strictness info exclusively. It is very much like (Nested) CPR, which-needs its nested fields to be evaluated in order for it to unbox nestedly.--There is the usual danger of reboxing, which as usual we ignore. But-if X is monomorphic, and has an UNPACK pragma, then this optimisation-is even more important. We don't want the wrapper to rebox an unboxed-argument, and pass an Int to $wfoo!--This works in nested situations like T10482-- data family Bar a- data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)- newtype instance Bar Int = Bar Int-- foo :: Bar ((Int, Int), Int) -> Int -> Int- foo f k = case f of BarPair x y ->- case burble of- True -> case x of- BarPair p q -> ...- False -> ...--The extra eagerness lets us produce a worker of type:- $wfoo :: Int# -> Int# -> Int# -> Int -> Int- $wfoo p# q# y# = ...--even though the `case x` is only lazily evaluated.----------- Historical note -------------We used to add data-con strictness demands when demand analysing case-expression. However, it was noticed in #15696 that this misses some cases. For-instance, consider the program (from T10482)-- data family Bar a- data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)- newtype instance Bar Int = Bar Int-- foo :: Bar ((Int, Int), Int) -> Int -> Int- foo f k =- case f of- BarPair x y -> case burble of- True -> case x of- BarPair p q -> ...- False -> ...--We really should be able to assume that `p` is already evaluated since it came-from a strict field of BarPair. This strictness would allow us to produce a-worker of type:-- $wfoo :: Int# -> Int# -> Int# -> Int -> Int- $wfoo p# q# y# = ...--even though the `case x` is only lazily evaluated--Indeed before we fixed #15696 this would happen since we would float the inner-`case x` through the `case burble` to get:-- foo f k =- case f of- BarPair x y -> case x of- BarPair p q -> case burble of- True -> ...- False -> ...--However, after fixing #15696 this could no longer happen (for the reasons-discussed in ticket:15696#comment:76). This means that the demand placed on `f`-would then be significantly weaker (since the False branch of the case on-`burble` is not strict in `p` or `q`).--Consequently, we now instead account for data-con strictness in mkWWstr_one,-applying the strictness demands to the final result of DmdAnal. The result is-that we get the strict demand signature we wanted even if we can't float-the case on `x` up through the case on `burble`.--Note [No nested Unboxed inside Boxed in demand signature]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-```-f p@(x,y)- | even (x+y) = []- | otherwise = [p]-```-Demand analysis will infer that the function body puts a demand of `1P(1!L,1!L)`-on 'p', e.g., Boxed on the outside but Unboxed on the inside. But worker/wrapper-can't unbox the pair components without unboxing the pair! So we better say-`1P(1L,1L)` in the demand signature in order not to spread wrong Boxity info.-That happens in 'finaliseBoxity'.--Note [No lazy, Unboxed demands in demand signature]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider T19407:-- data Huge = Huge Bool () ... () -- think: DynFlags- data T = T { h :: Huge, n :: Int }- f t@(T h _) = g h t- g (H b _ ... _) t = if b then 1 else n t--The body of `g` puts (approx.) demand `L!P(A,1)` on `t`. But we better-not put that demand in `g`'s demand signature, because worker/wrapper will not-in general unbox a lazy-and-unboxed demand like `L!P(..)`.-(The exception are known-to-be-evaluated arguments like strict fields,-see Note [Unboxing evaluated arguments].)--The program above is an example where spreading misinformed boxity through the-signature is particularly egregious. If we give `g` that signature, then `f`-puts demand `S!P(1!P(1L,A,..),ML)` on `t`. Now we will unbox `t` in `f` it and-we get-- f (T (H b _ ... _) n) = $wf b n- $wf b n = $wg b (T (H b x ... x) n)- $wg = ...--Massive reboxing in `$wf`! Solution: Trim boxity on lazy demands in-'finaliseBoxity', modulo Note [Unboxing evaluated arguments].--Note [Finalising boxity for demand signature]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The worker/wrapper pass must strictly adhere to the boxity decisions encoded-in the demand signature, because that is the information that demand analysis-propagates throughout the program. Failing to implement the strategy laid out-in the signature can result in reboxing in unexpected places. Hence, we must-completely anticipate unboxing decisions during demand analysis and reflect-these decicions in demand annotations. That is the job of 'finaliseBoxity',-which is defined here and called from demand analysis.--Here is a list of different Notes it has to take care of:-- * Note [No lazy, Unboxed demands in demand signature] such as `L!P(L)` in- general, but still allow Note [Unboxing evaluated arguments]- * Note [No nested Unboxed inside Boxed in demand signature] such as `1P(1!L)`- * Implement fixes for corner cases Note [Do not unbox class dictionaries]- and Note [mkWWstr and unsafeCoerce]--Then, in worker/wrapper blindly trusts the boxity info in the demand signature-and will not look at strictness info *at all*, in 'wantToUnboxArg'.- Note [non-algebraic or open body type warning] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There are a few cases where the W/W transformation is told that something@@ -898,6 +680,65 @@ This warning also triggers for the stream fusion library within `text`. We can'easily W/W constructed results like `Stream` because we have no simple way to express existential types in the worker's type signature.++Note [WW for calling convention]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we know a function f will always evaluate a particular argument+we might decide that it should rather get evaluated by the caller.+We call this "unlifting" the argument.+Sometimes the caller knows that the argument is already evaluated,+so we won't generate any code to enter/evaluate the argument.+This evaluation avoidance can be quite beneficial.+Especially for recursive functions who pass the same lifted argument+along on each iteration or walk over strict data structures.++One way to achieve this is to do a W/W split, where the wrapper does+the evaluation, and the worker can treat its arguments as unlifted.+The wrapper is small and will be inlined at almost all call sites and+the evaluation code in the wrapper can then cancel out with evaluation+done by the calling context if the argument is evaluated there.+Same idea as W/W to avoid allocation really, just for a different kind+of work.++Performing W/W might not always be a win. In particular it's easy to break+(badly written, but common) rule frameworks by doing additional W/W splits.+See #20364 for a more detailed explaination.++Hence we have the following strategies with different trade-offs:+A) Never do W/W *just* for unlifting of arguments.+ + Very conservative - doesn't break any rules+ - Lot's of performance left on the table+B) Do W/W on just about anything where it might be+ beneficial.+ + Exploits pretty much every oppertunity for unlifting.+ - A bit of compile time/code size cost for all the wrappers.+ - Can break rules which would otherwise fire. See #20364.+C) Unlift *any* (non-boot exported) functions arguments if they are strict.+ That is instead of creating a Worker with the new calling convention we+ change the calling convention of the binding itself.+ + Exploits every opportunity for unlifting.+ + Maybe less bad interactions with rules.+ - Requires tracking of boot-exported definitions.+ - Requires either:+ ~ Eta-expansion at *all* call sites in order to generate+ an impedance matcher function. Leading to massive code bloat.+ Essentially we end up creating a imprompto wrapper function+ wherever we wouldn't inline the wrapper with a W/W approach.+ ~ There is the option of achieving this without eta-expansion if we instead expand+ the partial application code to check for demands on the calling convention and+ for it to evaluate the arguments. The main downsides there would be the complexity+ of the implementation and that it carries a certain overhead even for functions who+ don't take advantage of this functionality. I haven't tried this approach because it's+ not trivial to implement and doing W/W splits seems to work well enough.++Currently we use the first approach A) by default, with a flag that allows users to fall back to the+more aggressive approach B).+I also tried the third approach C) using eta-expansion at call sites to avoid modifying the PAP-handling+code which wasn't fruitful. See https://gitlab.haskell.org/ghc/ghc/-/merge_requests/5614#note_389903.+We could still try to do C) in the future by having PAP calls which will evaluate the required arguments+before calling the partially applied function. But this would be neither a small nor simple change so we+stick with A) and a flag for B) for now.+See also Note [Tag Inference] and Note [Strict Worker Ids] -} {-@@ -911,26 +752,29 @@ mkWWstr :: WwOpts -> [Var] -- Wrapper args; have their demand info on them -- *Includes type variables*- -> UniqSM (Bool, -- Is this useful- [Var], -- Worker args+ -> [CbvMark] -- cbv info for arguments+ -> UniqSM (Bool, -- Will this result in a useful worker+ [(Var,CbvMark)], -- Worker args/their call-by-value semantics. CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call -- and without its lambdas -- This fn adds the unboxing [CoreExpr]) -- Reboxed args for the call to the -- original RHS. Corresponds one-to-one -- with the wrapper arg vars-mkWWstr opts args- = go args+mkWWstr opts args cbv_info+ = go args cbv_info where- go_one arg = mkWWstr_one opts arg+ go_one arg cbv = mkWWstr_one opts arg cbv - go [] = return (False, [], nop_fn, [])- go (arg : args) = do { (useful1, args1, wrap_fn1, wrap_arg) <- go_one arg- ; (useful2, args2, wrap_fn2, wrap_args) <- go args+ go [] _ = return (badWorker, [], nop_fn, [])+ go (arg : args) (cbv:cbvs)+ = do { (useful1, args1, wrap_fn1, wrap_arg) <- go_one arg cbv+ ; (useful2, args2, wrap_fn2, wrap_args) <- go args cbvs ; return ( useful1 || useful2 , args1 ++ args2 , wrap_fn1 . wrap_fn2 , wrap_arg:wrap_args ) }+ go _ _ = panic "mkWWstr: Impossible - cbv/arg length missmatch" ---------------------- -- mkWWstr_one wrap_var = (useful, work_args, wrap_fn, wrap_arg)@@ -939,47 +783,73 @@ -- * wrap_arg assumes work_args are in scope, and builds a ConApp that -- reconstructs the RHS of wrap_var that we pass to the original RHS -- See Note [Worker/wrapper for Strictness and Absence]-mkWWstr_one :: WwOpts -> Var -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr)-mkWWstr_one opts arg =- case wantToUnboxArg fam_envs arg_ty arg_dmd of+mkWWstr_one :: WwOpts+ -> Var+ -> CbvMark+ -> UniqSM (Bool, [(Var,CbvMark)], CoreExpr -> CoreExpr, CoreExpr)+mkWWstr_one opts arg marked_cbv =+ case wantToUnboxArg True fam_envs arg_ty arg_dmd of _ | isTyVar arg -> do_nothing DropAbsent | Just absent_filler <- mkAbsentFiller opts arg- -- Absent case. We can't always handle absence for arbitrary+ -- Absent case. Dropt the argument from the worker.+ -- We can't always handle absence for arbitrary -- unlifted types, so we need to choose just the cases we can -- (that's what mkAbsentFiller does)- -> return (True, [], nop_fn, absent_filler)+ -> return (goodWorker, [], nop_fn, absent_filler) - Unbox dcpc ds -> unbox_one_arg opts arg ds dcpc+ Unbox dcpc ds -> unbox_one_arg opts arg ds dcpc marked_cbv + Unlift -> return ( wwForUnlifting opts+ , [(setIdUnfolding arg evaldUnfolding, MarkedCbv)]+ , nop_fn+ , varToCoreExpr arg)+ _ -> do_nothing -- Other cases, like StopUnboxing where fam_envs = wo_fam_envs opts arg_ty = idType arg arg_dmd = idDemandInfo arg- do_nothing = return (False, [arg], nop_fn, varToCoreExpr arg)+ -- Type args don't get cbv marks+ arg_cbv = if isTyVar arg then NotMarkedCbv else marked_cbv+ do_nothing = return (badWorker, [(arg,arg_cbv)], nop_fn, varToCoreExpr arg) unbox_one_arg :: WwOpts -> Var -> [Demand] -> DataConPatContext- -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr)+ -> CbvMark+ -> UniqSM (Bool, [(Var,CbvMark)], CoreExpr -> CoreExpr, CoreExpr) unbox_one_arg opts arg_var ds DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args , dcpc_co = co }+ _marked_cbv = do { pat_bndrs_uniqs <- getUniquesM ; let ex_name_fss = map getOccFS $ dataConExTyCoVars dc+ -- Create new arguments we get when unboxing dc (ex_tvs', arg_ids) = dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg_var) dc tc_args+ -- Apply str info to new args. arg_ids' = zipWithEqual "unbox_one_arg" setIdDemandInfo arg_ids ds unbox_fn = mkUnpackCase (Var arg_var) co (idMult arg_var) dc (ex_tvs' ++ arg_ids')- ; (_, worker_args, wrap_fn, wrap_args) <- mkWWstr opts (ex_tvs' ++ arg_ids')+ -- Mark arguments coming out of strict fields as evaluated and give them cbv semantics. See Note [Strict Worker Ids]+ cbv_arg_marks = zipWithEqual "unbox_one_arg" bangToMark (dataConRepStrictness dc) arg_ids'+ unf_args = zipWith setEvald arg_ids' cbv_arg_marks+ cbv_marks = (map (const NotMarkedCbv) ex_tvs') ++ cbv_arg_marks+ ; (_sub_args_quality, worker_args, wrap_fn, wrap_args) <- mkWWstr opts (ex_tvs' ++ unf_args) cbv_marks ; let wrap_arg = mkConApp dc (map Type tc_args ++ wrap_args) `mkCast` mkSymCo co- ; return (True, worker_args, unbox_fn . wrap_fn, wrap_arg) }+ ; return (goodWorker, worker_args, unbox_fn . wrap_fn, wrap_arg) } -- Don't pass the arg, rebox instead+ where bangToMark :: StrictnessMark -> Id -> CbvMark+ bangToMark NotMarkedStrict _ = NotMarkedCbv+ bangToMark MarkedStrict v+ | isUnliftedType (idType v) = NotMarkedCbv+ | otherwise = MarkedCbv+ setEvald var NotMarkedCbv = var+ setEvald var MarkedCbv = setIdUnfolding var evaldUnfolding -- | Tries to find a suitable absent filler to bind the given absent identifier -- to. See Note [Absent fillers].@@ -1031,6 +901,7 @@ E.g. B comes from a function like f x = error "urk" and the absent demand A can come from Note [Unboxing evaluated arguments]+ in GHC.Core.Opt.DmdAnal. 2. If the argument is evaluated strictly (or known to be eval'd), we can take a view into the product demand ('viewProd'). In accordance@@ -1055,7 +926,7 @@ g c p = case p of (a,b) -> $gw c a b $gw c a b = if c then a else b -2a But do /not/ split if Boxity Analysis said "Boxed".+2a But do /not/ unbox if Boxity Analysis said "Boxed". In this case, 'wantToUnboxArg' returns 'StopUnboxing'. Otherwise we risk decomposing and reboxing a massive tuple which is barely used. Example:@@ -1069,10 +940,15 @@ Imagine that it had millions of fields. This actually happened in GHC itself where the tuple was DynFlags +2b But if e.g. a large tuple or product type is always demanded we might+ decide to "unlift" it. That is tighten the calling convention for that+ argument to require it to be passed as a pointer to the value itself.+ See Note [WW for calling convention].+ 3. In all other cases (e.g., lazy, used demand and not eval'd),- 'finaliseBoxity' will have cleared the Boxity flag to 'Boxed'- (see Note [Finalising boxity for demand signature]) and- 'wantToUnboxArg' returns 'StopUnboxing' so that 'mkWWstr_one'+ 'finaliseArgBoxities' will have cleared the Boxity flag to 'Boxed'+ (see Note [Finalising boxity for demand signatures] in GHC.Core.Opt.DmdAnal)+ and 'wantToUnboxArg' returns 'StopUnboxing' so that 'mkWWstr_one' stops unboxing. Note [Worker/wrapper for bottoming functions]@@ -1177,7 +1053,7 @@ Ideally, we'd just look at the 'StrictnessMark' of the DataCon's field, but it's quite nasty to thread the marks though 'mkWWstr' and 'mkWWstr_one'. So we rather look out for a necessary condition for strict fields:- Note [Unboxing evaluated arguments] makes it so that the demand on+ Note [Unboxing evaluated arguments] in DmdAnal makes it so that the demand on 'zs' is absent and /strict/: It will get cardinality 'C_10', the empty interval, rather than 'C_00'. Hence the 'isStrictDmd' check: It guarantees we never fill in an error-thunk for an absent strict field.@@ -1410,56 +1286,6 @@ -> combineIRDCRs (map (\dc -> go_dc (subWithInf fuel 1) rec_tc' dc) dcs) -- See Note [Detecting recursive data constructors], point (4) --- | A specialised Bool for an argument to 'finaliseBoxity'.--- See Note [Do not unbox class dictionaries].-data InsideInlineableFun- = NotInsideInlineableFun -- ^ Not in an inlineable fun.- | InsideInlineableFun -- ^ We are in an inlineable fun, so we won't- -- unbox dictionary args.- deriving Eq---- | This function makes sure that the demand only says 'Unboxed' where--- worker/wrapper should actually unbox and trims any boxity beyond that.--- Called for every demand annotation during DmdAnal.------ > data T a = T !a--- > f :: (T (Int,Int), Int) -> ()--- > f p = ... -- demand on p: 1!P(L!P(L!P(L), L!P(L)), L!P(L))------ 'finaliseBoxity' will trim the demand on 'p' to 1!P(L!P(LP(L), LP(L)), LP(L)).--- This is done when annotating lambdas and thunk bindings.--- See Note [Finalising boxity for demand signature]-finaliseBoxity- :: FamInstEnvs- -> InsideInlineableFun -- ^ See the haddocks on 'InsideInlineableFun'- -> Type -- ^ Type of the argument- -> Demand -- ^ How the arg was used- -> Demand-finaliseBoxity env in_inl_fun ty dmd = go NotMarkedStrict ty dmd- where- go mark ty dmd@(n :* _) =- case wantToUnboxArg env ty dmd of- DropAbsent -> dmd- Unbox DataConPatContext{dcpc_dc=dc, dcpc_tc_args=tc_args} ds- -- See Note [No lazy, Unboxed demands in demand signature]- -- See Note [Unboxing evaluated arguments]- | isStrict n || isMarkedStrict mark- -- See Note [Do not unbox class dictionaries]- , in_inl_fun == NotInsideInlineableFun || not (isClassPred ty)- -- See Note [mkWWstr and unsafeCoerce]- , ds `lengthIs` dataConRepArity dc- , let arg_tys = dubiousDataConInstArgTys dc tc_args- -> -- pprTrace "finaliseBoxity:Unbox" (ppr ty $$ ppr dmd $$ ppr ds) $- n :* (mkProd Unboxed $! zip_go_with_marks dc arg_tys ds)- -- See Note [No nested Unboxed inside Boxed in demand signature]- _ -> trimBoxity dmd-- -- See Note [Unboxing evaluated arguments]- zip_go_with_marks dc arg_tys ds = case dataConWrapId_maybe dc of- Nothing -> strictZipWith (go NotMarkedStrict) arg_tys ds- -- Shortcut when DataCon worker=wrapper- Just _ -> strictZipWith3 go (dataConRepStrictness dc) arg_tys ds- {- ************************************************************************ * *@@ -1473,14 +1299,14 @@ :: WwOpts -> Type -- function body -> Cpr -- CPR analysis results- -> UniqSM (Bool, -- Is w/w'ing useful?+ -> UniqSM (Bool, -- Is w/w'ing useful? CoreExpr -> CoreExpr, -- New wrapper. 'nop_fn' if not useful CoreExpr -> CoreExpr, -- New worker. 'nop_fn' if not useful Type) -- Type of worker's body. -- Just the input body_ty if not useful -- ^ Entrypoint to CPR W/W. See Note [Worker/wrapper for CPR] for an overview. mkWWcpr_entry opts body_ty body_cpr- | not (wo_cpr_anal opts) = return (False, nop_fn, nop_fn, body_ty)+ | not (wo_cpr_anal opts) = return (badWorker, nop_fn, nop_fn, body_ty) | otherwise = do -- Part (1) res_bndr <- mk_res_bndr body_ty@@ -1498,8 +1324,8 @@ work_fn body = bind_res_bndr body (work_unpack_res transit_tup) -- 1 2 3 work_body_ty = exprType transit_tup return $ if not useful- then (False, nop_fn, nop_fn, body_ty)- else (True, wrap_fn, work_fn, work_body_ty)+ then (badWorker, nop_fn, nop_fn, body_ty)+ else (goodWorker, wrap_fn, work_fn, work_body_ty) -- | Part (1) of Note [Worker/wrapper for CPR]. mk_res_bndr :: Type -> UniqSM Id@@ -1522,7 +1348,7 @@ mkWWcpr _opts vars [] = -- special case: No CPRs means all top (for example from FlatConCpr), -- hence stop WW.- return (False, toOL vars, map varToCoreExpr vars, nop_fn)+ return (badWorker, toOL vars, map varToCoreExpr vars, nop_fn) mkWWcpr opts vars cprs = do -- No existentials in 'vars'. 'wantToUnboxResult' should have checked that. massertPpr (not (any isTyVar vars)) (ppr vars $$ ppr cprs)@@ -1541,7 +1367,7 @@ , Unbox dcpc arg_cprs <- wantToUnboxResult (wo_fam_envs opts) (idType res_bndr) cpr = unbox_one_result opts res_bndr arg_cprs dcpc | otherwise- = return (False, unitOL res_bndr, varToCoreExpr res_bndr, nop_fn)+ = return (badWorker, unitOL res_bndr, varToCoreExpr res_bndr, nop_fn) unbox_one_result :: WwOpts -> Id -> [Cpr] -> DataConPatContext -> UniqSM CprWwResultOne@@ -1570,8 +1396,8 @@ -- Don't try to WW an unboxed tuple return type when there's nothing inside -- to unbox further. return $ if isUnboxedTupleDataCon dc && not nested_useful- then ( False, unitOL res_bndr, Var res_bndr, nop_fn )- else ( True+ then ( badWorker, unitOL res_bndr, Var res_bndr, nop_fn )+ else ( goodWorker , transit_vars , rebuilt_result , this_work_unbox_res . work_unbox_res
compiler/GHC/CoreToStg.hs view
@@ -18,6 +18,7 @@ import GHC.Prelude import GHC.Driver.Session+import GHC.Driver.Config.Stg.Debug import GHC.Core import GHC.Core.Utils ( exprType, findDefault, isJoinBind@@ -29,6 +30,7 @@ import GHC.Stg.Syntax import GHC.Stg.Debug+import GHC.Stg.Utils import GHC.Types.RepType import GHC.Types.Id.Make ( coercionTokenId )@@ -244,7 +246,7 @@ -- See Note [Mapping Info Tables to Source Positions] (!pgm'', !denv) = if gopt Opt_InfoTableMap dflags- then collectDebugInformation dflags ml pgm'+ then collectDebugInformation (initStgDebugOpts dflags) ml pgm' else (pgm', emptyInfoTableProvMap) prof = ways dflags `hasWay` WayProf
compiler/GHC/CoreToStg/Prep.hs view
@@ -82,9 +82,8 @@ import Control.Monad {---- ------------------------------------------------------------------------------ Note [CorePrep Overview]--- ---------------------------------------------------------------------------+Note [CorePrep Overview]+~~~~~~~~~~~~~~~~~~~~~~~~ The goal of this pass is to prepare for code generation. @@ -300,7 +299,7 @@ -- If we want to generate debug info, we put a source note on the -- worker. This is useful, especially for heap profiling. tick_it name- | debugLevel dflags == 0 = id+ | not (needSourceNotes dflags) = id | RealSrcSpan span _ <- nameSrcSpan name = tick span | Just file <- ml_hs_file mod_loc = tick (span1 file) | otherwise = tick (span1 "???")@@ -1025,7 +1024,7 @@ go terminal as = (terminal, as) cpe_app :: CorePrepEnv- -> CoreExpr+ -> CoreExpr -- The thing we are calling -> [ArgInfo] -> UniqSM (Floats, CpeRhs) cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args)@@ -1171,7 +1170,7 @@ rebuild_app :: CorePrepEnv -> [ArgInfo] -- The arguments (inner to outer)- -> CpeApp+ -> CpeApp -- The function -> Floats -> [Demand] -> Maybe Arity@@ -1519,8 +1518,9 @@ Note [Eta expansion of hasNoBinding things in CorePrep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ maybeSaturate deals with eta expanding to saturate things that can't deal with-unsaturated applications (identified by 'hasNoBinding', currently just-foreign calls and unboxed tuple/sum constructors).+unsaturated applications (identified by 'hasNoBinding', currently+foreign calls, unboxed tuple/sum constructors, and representation-polymorphic+primitives such as 'coerce' and 'unsafeCoerce#'). Historical Note: Note that eta expansion in CorePrep used to be very fragile due to the "prediction" of CAFfyness that we used to make during tidying.@@ -1534,14 +1534,27 @@ | hasNoBinding fn -- There's no binding = return $ wrapLamBody (\body -> foldr mkTick body unsat_ticks) sat_expr + | mark_arity > 0 -- A strict worker. See Note [Strict Worker Ids]+ , not applied_marks+ = assertPpr+ ( not (isJoinId fn)) -- See Note [Do not eta-expand join points]+ ( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$+ text "marks:" <+> ppr (idCbvMarks_maybe fn) $$+ text "join_arity" <+> ppr (idJoinArity fn)+ ) $+ return sat_expr+ | otherwise = assert (null unsat_ticks) $ return expr where- fn_arity = idArity fn- excess_arity = fn_arity - n_args- sat_expr = cpeEtaExpand excess_arity expr-+ mark_arity = idCbvMarkArity fn+ fn_arity = idArity fn+ excess_arity = (max fn_arity mark_arity) - n_args+ sat_expr = cpeEtaExpand excess_arity expr+ applied_marks = n_args >= (length . dropWhile (not . isMarkedCbv) . reverse . expectJust "maybeSaturate" $ (idCbvMarks_maybe fn))+ -- For join points we never eta-expand (See Note [Do not eta-expand join points])+ -- so we assert all arguments that need to be passed cbv are visible so that the backend can evalaute them if required.. {- ************************************************************************ * *@@ -1621,13 +1634,19 @@ , not (any (`elemVarSet` fvs_remaining) bndrs) , exprIsHNF remaining_expr -- Don't turn value into a non-value -- else the behaviour with 'seq' changes- = Just remaining_expr+ =+ -- pprTrace "prep-reduce" (+ -- text "reduced:" <> ppr remaining_expr $$+ -- ppr (remaining_args)+ -- ) $+ Just remaining_expr where (f, args) = collectArgs expr remaining_expr = mkApps f remaining_args fvs_remaining = exprFreeVars remaining_expr (remaining_args, last_args) = splitAt n_remaining args n_remaining = length args - length bndrs+ n_remaining_vals = length $ filter isRuntimeArg remaining_args ok bndr (Var arg) = bndr == arg ok _ _ = False@@ -1635,9 +1654,11 @@ -- We can't eta reduce something which must be saturated. ok_to_eta_reduce (Var f) = not (hasNoBinding f) && not (isLinearType (idType f)) && -- Unsure why this is unsafe.- (not (isJoinId f) || idJoinArity f <= n_remaining)+ (not (isJoinId f) || idJoinArity f <= n_remaining) && -- Don't undersaturate join points. -- See Note [Invariants on join points] in GHC.Core, and #20599+ (idCbvMarkArity f <= n_remaining_vals)+ -- Similar for StrictWorkerIds. See Note [Strict Worker Ids] ok_to_eta_reduce _ = False -- Safe. ToDo: generalise@@ -2173,7 +2194,7 @@ -- --------------------------------------------------------------------------- -- -- Note [Floating Ticks in CorePrep]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- It might seem counter-intuitive to float ticks by default, given -- that we don't actually want to move them if we can help it. On the -- other hand, nothing gets very far in CorePrep anyway, and we want
compiler/GHC/Driver/Backpack.hs view
@@ -570,20 +570,20 @@ in case node of InstantiationNode _ _ -> case recomp of- MustCompile -> showMsg (text "Instantiating ") empty UpToDate | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping ") empty | otherwise -> return ()- RecompBecause reason -> showMsg (text "Instantiating ")- (text " [" <> pprWithUnitState state (ppr reason) <> text "]")+ NeedsRecompile reason0 -> showMsg (text "Instantiating ") $ case reason0 of+ MustCompile -> empty+ RecompBecause reason -> text " [" <> pprWithUnitState state (ppr reason) <> text "]" ModuleNode _ _ -> case recomp of- MustCompile -> showMsg (text "Compiling ") empty UpToDate | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping ") empty | otherwise -> return ()- RecompBecause reason -> showMsg (text "Compiling ")- (text " [" <> pprWithUnitState state (ppr reason) <> text "]")+ NeedsRecompile reason0 -> showMsg (text "Compiling ") $ case reason0 of+ MustCompile -> empty+ RecompBecause reason -> text " [" <> pprWithUnitState state (ppr reason) <> text "]" LinkNode _ _ -> showMsg (text "Linking ") empty -- | 'PprStyle' for Backpack messages; here we usually want the module to
compiler/GHC/Driver/CodeOutput.hs view
@@ -335,7 +335,7 @@ <> semi -- | Generate code to initialise info pointer origin--- See note [Mapping Info Tables to Source Positions]+-- See Note [Mapping Info Tables to Source Positions] ipInitCode :: Bool -- is Opt_InfoTableMap enabled or not -> Platform
+ compiler/GHC/Driver/Config/Stg/Debug.hs view
@@ -0,0 +1,14 @@+module GHC.Driver.Config.Stg.Debug+ ( initStgDebugOpts+ ) where++import GHC.Stg.Debug++import GHC.Driver.Session++-- | Initialize STG pretty-printing options from DynFlags+initStgDebugOpts :: DynFlags -> StgDebugOpts+initStgDebugOpts dflags = StgDebugOpts+ { stgDebug_infoTableMap = gopt Opt_InfoTableMap dflags+ , stgDebug_distinctConstructorTables = gopt Opt_DistinctConstructorTables dflags+ }
+ compiler/GHC/Driver/Config/Stg/Lift.hs view
@@ -0,0 +1,15 @@+module GHC.Driver.Config.Stg.Lift+ ( initStgLiftConfig+ ) where++import GHC.Stg.Lift.Config++import GHC.Driver.Session++initStgLiftConfig :: DynFlags -> StgLiftConfig+initStgLiftConfig dflags = StgLiftConfig+ { c_targetProfile = targetProfile dflags+ , c_liftLamsRecArgs = liftLamsRecArgs dflags+ , c_liftLamsNonRecArgs = liftLamsNonRecArgs dflags+ , c_liftLamsKnown = liftLamsKnown dflags+ }
+ compiler/GHC/Driver/Config/Stg/Pipeline.hs view
@@ -0,0 +1,46 @@+module GHC.Driver.Config.Stg.Pipeline+ ( initStgPipelineOpts+ ) where++import GHC.Prelude++import Control.Monad (guard)++import GHC.Stg.Pipeline++import GHC.Driver.Config.Diagnostic+import GHC.Driver.Config.Stg.Lift+import GHC.Driver.Config.Stg.Ppr+import GHC.Driver.Session++-- | Initialize STG pretty-printing options from DynFlags+initStgPipelineOpts :: DynFlags -> Bool -> StgPipelineOpts+initStgPipelineOpts dflags for_bytecode = StgPipelineOpts+ { stgPipeline_lint = do+ guard $ gopt Opt_DoStgLinting dflags+ Just $ initDiagOpts dflags+ , stgPipeline_pprOpts = initStgPprOpts dflags+ , stgPipeline_phases = getStgToDo for_bytecode dflags+ }++-- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.+getStgToDo+ :: Bool -- ^ Are we preparing for bytecode?+ -> DynFlags+ -> [StgToDo]+getStgToDo for_bytecode dflags =+ filter (/= StgDoNothing)+ [ mandatory StgUnarise+ -- Important that unarisation comes first+ -- See Note [StgCse after unarisation] in GHC.Stg.CSE+ , optional Opt_StgCSE StgCSE+ , optional Opt_StgLiftLams $ StgLiftLams $ initStgLiftConfig dflags+ , runWhen for_bytecode StgBcPrep+ , optional Opt_StgStats StgStats+ ] where+ optional opt = runWhen (gopt opt dflags)+ mandatory = id++runWhen :: Bool -> StgToDo -> StgToDo+runWhen True todo = todo+runWhen _ _ = StgDoNothing
+ compiler/GHC/Driver/Config/Stg/Ppr.hs view
@@ -0,0 +1,13 @@+module GHC.Driver.Config.Stg.Ppr+ ( initStgPprOpts+ ) where++import GHC.Stg.Syntax++import GHC.Driver.Session++-- | Initialize STG pretty-printing options from DynFlags+initStgPprOpts :: DynFlags -> StgPprOpts+initStgPprOpts dflags = StgPprOpts+ { stgSccEnabled = sccProfilingEnabled dflags+ }
compiler/GHC/Driver/Config/StgToCmm.hs view
@@ -29,6 +29,7 @@ , stgToCmmTickyAllocd = gopt Opt_Ticky_Allocd dflags , stgToCmmTickyLNE = gopt Opt_Ticky_LNE dflags , stgToCmmTickyDynThunk = gopt Opt_Ticky_Dyn_Thunk dflags+ , stgToCmmTickyTag = gopt Opt_Ticky_Tag dflags -- flags , stgToCmmLoopification = gopt Opt_Loopification dflags , stgToCmmAlignCheck = gopt Opt_AlignmentSanitisation dflags@@ -43,6 +44,7 @@ , stgToCmmPIE = gopt Opt_PIE dflags , stgToCmmExtDynRefs = gopt Opt_ExternalDynamicRefs dflags , stgToCmmDoBoundsCheck = gopt Opt_DoBoundsChecking dflags+ , stgToCmmDoTagCheck = gopt Opt_DoTagInferenceChecks dflags -- backend flags , stgToCmmAllowBigArith = not ncg , stgToCmmAllowQuotRemInstr = ncg && (x86ish || ppc)
compiler/GHC/Driver/GenerateCgIPEStub.hs view
@@ -17,19 +17,23 @@ import GHC.Data.Stream (Stream, liftIO) import qualified GHC.Data.Stream as Stream import GHC.Driver.Env (hsc_dflags)+import GHC.Driver.Env.Types (HscEnv) import GHC.Driver.Flags (GeneralFlag (Opt_InfoTableMap)) import GHC.Driver.Session (gopt, targetPlatform) import GHC.Driver.Config.StgToCmm-import GHC.Plugins (HscEnv, NonCaffySet) import GHC.Prelude import GHC.Runtime.Heap.Layout (isStackRep) import GHC.Settings (Platform, platformUnregisterised) import GHC.StgToCmm.Monad (getCmm, initC, runC, initFCodeState) import GHC.StgToCmm.Prof (initInfoTableProv) import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)+import GHC.Stg.InferTags.TagSig (TagSig) import GHC.Types.IPE (InfoTableProvMap (provInfoTables), IpeSourceLocation)+import GHC.Types.Name.Set (NonCaffySet)+import GHC.Types.Name.Env (NameEnv) import GHC.Types.Tickish (GenTickish (SourceNote)) import GHC.Unit.Types (Module)+import GHC.Utils.Misc {- Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]@@ -176,8 +180,8 @@ remembered in a `Maybe`. -} -generateCgIPEStub :: HscEnv -> Module -> InfoTableProvMap -> Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) -> Stream IO CmmGroupSRTs CgInfos-generateCgIPEStub hsc_env this_mod denv s = do+generateCgIPEStub :: HscEnv -> Module -> InfoTableProvMap -> NameEnv TagSig -> Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) -> Stream IO CmmGroupSRTs CgInfos+generateCgIPEStub hsc_env this_mod denv tag_sigs s = do let dflags = hsc_dflags hsc_env platform = targetPlatform dflags fstate = initFCodeState platform@@ -189,12 +193,12 @@ -- Yield Cmm for Info Table Provenance Entries (IPEs) let denv' = denv {provInfoTables = Map.fromList (map (\(_, i, t) -> (cit_lbl i, t)) labeledInfoTablesWithTickishes)}- ((ipeStub, ipeCmmGroup), _) = runC (initStgToCmmConfig dflags this_mod) fstate cgState $ getCmm (initInfoTableProv (map sndOfTriple labeledInfoTablesWithTickishes) denv')+ ((ipeStub, ipeCmmGroup), _) = runC (initStgToCmmConfig dflags this_mod) fstate cgState $ getCmm (initInfoTableProv (map sndOf3 labeledInfoTablesWithTickishes) denv') (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline hsc_env (emptySRT this_mod) ipeCmmGroup Stream.yield ipeCmmGroupSRTs - return CgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub}+ return CgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub, cgTagSigs = tag_sigs} where collect :: Platform -> [(Label, CmmInfoTable, Maybe IpeSourceLocation)] -> CmmGroupSRTs -> IO ([(Label, CmmInfoTable, Maybe IpeSourceLocation)], CmmGroupSRTs) collect platform acc cmmGroupSRTs = do@@ -205,9 +209,6 @@ collectNothing :: [a] -> CmmGroupSRTs -> IO ([a], CmmGroupSRTs) collectNothing _ cmmGroupSRTs = pure ([], cmmGroupSRTs) - sndOfTriple :: (a, b, c) -> b- sndOfTriple (_, b, _) = b- collectInfoTables :: CmmGroupSRTs -> [(Label, CmmInfoTable)] collectInfoTables cmmGroup = concat $ catMaybes $ map extractInfoTables cmmGroup @@ -262,7 +263,7 @@ where find :: CLabel -> [CmmNode O O] -> Maybe IpeSourceLocation -> Maybe IpeSourceLocation find label (b : blocks) lastTick = case b of- (CmmStore _ (CmmLit (CmmLabel l))) -> if label == l then lastTick else find label blocks lastTick+ (CmmStore _ (CmmLit (CmmLabel l)) _) -> if label == l then lastTick else find label blocks lastTick (CmmTick (SourceNote span name)) -> find label blocks $ Just (span, name) _ -> find label blocks lastTick find _ [] _ = Nothing
compiler/GHC/Driver/Main.hs view
@@ -106,6 +106,8 @@ import GHC.Driver.CodeOutput import GHC.Driver.Config.Logger (initLogFlags) import GHC.Driver.Config.Parser (initParserOpts)+import GHC.Driver.Config.Stg.Ppr (initStgPprOpts)+import GHC.Driver.Config.Stg.Pipeline (initStgPipelineOpts) import GHC.Driver.Config.StgToCmm (initStgToCmmConfig) import GHC.Driver.Config.Diagnostic import GHC.Driver.Hooks@@ -244,6 +246,8 @@ import Data.List.NonEmpty (NonEmpty ((:|))) +import GHC.Stg.InferTags+ {- ********************************************************************** %* * Initialisation@@ -600,7 +604,7 @@ Nothing -> hscParse' mod_summary tc_result0 <- tcRnModule' mod_summary keep_rn' hpm if hsc_src == HsigFile- then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 mod_summary Nothing+ then do (iface, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 mod_summary ioMsgMaybe $ hoistTcRnMessage $ tcRnMergeSignatures hsc_env hpm tc_result0 iface else return tc_result0@@ -741,42 +745,51 @@ Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] mod_summary) Nothing -> return () - -- First check to see if the interface file agrees with the- -- source file.- (recomp_iface_reqd, mb_checked_iface)- <- {-# SCC "checkOldIface" #-}- liftIO $ checkOldIface hsc_env mod_summary mb_old_iface- -- Check to see whether the expected build products already exist.- -- If they don't exists then we trigger recompilation.- let lcl_dflags = ms_hspp_opts mod_summary- (recomp_obj_reqd, mb_linkable) <-- case () of- -- No need for a linkable, we're good to go- _ | NoBackend <- backend lcl_dflags -> return (UpToDate, Nothing)- -- Interpreter can use either already loaded bytecode or loaded object code- | not (backendProducesObject (backend lcl_dflags)) -> do- res <- liftIO $ checkByteCode old_linkable- case res of- (_, Just{}) -> return res- _ -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary- -- Need object files for making object files- | backendProducesObject (backend lcl_dflags) -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary- | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags)- let recomp_reqd = recomp_iface_reqd `mappend` recomp_obj_reqd- -- save the interface that comes back from checkOldIface.+ -- First check to see if the interface file agrees with the+ -- source file.+ --+ -- Save the interface that comes back from checkOldIface. -- In one-shot mode we don't have the old iface until this -- point, when checkOldIface reads it from the disk.- let mb_old_hash = fmap (mi_iface_hash . mi_final_exts) mb_checked_iface- msg recomp_reqd- case mb_checked_iface of- Just iface | not (recompileRequired recomp_reqd) ->- return $ HscUpToDate iface mb_linkable- _ ->- return $ HscRecompNeeded mb_old_hash+ recomp_if_result+ <- {-# SCC "checkOldIface" #-}+ liftIO $ checkOldIface hsc_env mod_summary mb_old_iface+ case recomp_if_result of+ OutOfDateItem reason mb_checked_iface -> do+ msg $ NeedsRecompile reason+ return $ HscRecompNeeded $ fmap (mi_iface_hash . mi_final_exts) mb_checked_iface+ UpToDateItem checked_iface -> do+ let lcl_dflags = ms_hspp_opts mod_summary+ case backend lcl_dflags of+ -- No need for a linkable, we're good to go+ NoBackend -> do+ msg $ UpToDate+ return $ HscUpToDate checked_iface Nothing+ -- Do need linkable+ _ -> do+ -- Check to see whether the expected build products already exist.+ -- If they don't exists then we trigger recompilation.+ recomp_linkable_result <- case () of+ -- Interpreter can use either already loaded bytecode or loaded object code+ _ | Interpreter <- backend lcl_dflags -> do+ let res = checkByteCode old_linkable+ case res of+ UpToDateItem _ -> pure res+ _ -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary+ -- Need object files for making object files+ | backendProducesObject (backend lcl_dflags) -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary+ | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags)+ case recomp_linkable_result of+ UpToDateItem linkable -> do+ msg $ UpToDate+ return $ HscUpToDate checked_iface $ Just linkable+ OutOfDateItem reason _ -> do+ msg $ NeedsRecompile reason+ return $ HscRecompNeeded $ Just $ mi_iface_hash $ mi_final_exts $ checked_iface -- | Check that the .o files produced by compilation are already up-to-date -- or not.-checkObjects :: DynFlags -> Maybe Linkable -> ModSummary -> IO (RecompileRequired, Maybe Linkable)+checkObjects :: DynFlags -> Maybe Linkable -> ModSummary -> IO (MaybeValidated Linkable) checkObjects dflags mb_old_linkable summary = do let dt_enabled = gopt Opt_BuildDynamicToo dflags@@ -789,11 +802,11 @@ -- that's there, and if it's not, regenerate both .o and -- .dyn_o checkDynamicObj k = if dt_enabled- then case (>=) <$> mb_dyn_obj_date <*> mb_if_date of- Just True -> k- _ -> return (RecompBecause MissingDynObjectFile, Nothing)- -- Not in dynamic-too mode- else k+ then case (>=) <$> mb_dyn_obj_date <*> mb_if_date of+ Just True -> k+ _ -> return $ outOfDateItemBecause MissingDynObjectFile Nothing+ -- Not in dynamic-too mode+ else k checkDynamicObj $ case (,) <$> mb_obj_date <*> mb_if_date of@@ -802,20 +815,20 @@ case mb_old_linkable of Just old_linkable | isObjectLinkable old_linkable, linkableTime old_linkable == obj_date- -> return $ (UpToDate, Just old_linkable)- _ -> (UpToDate,) . Just <$> findObjectLinkable this_mod obj_fn obj_date- _ -> return (RecompBecause MissingObjectFile, Nothing)+ -> return $ UpToDateItem old_linkable+ _ -> UpToDateItem <$> findObjectLinkable this_mod obj_fn obj_date+ _ -> return $ outOfDateItemBecause MissingObjectFile Nothing -- | Check to see if we can reuse the old linkable, by this point we will -- have just checked that the old interface matches up with the source hash, so -- no need to check that again here-checkByteCode :: Maybe Linkable -> IO (RecompileRequired, Maybe Linkable)+checkByteCode :: Maybe Linkable -> MaybeValidated Linkable checkByteCode mb_old_linkable = case mb_old_linkable of Just old_linkable | not (isObjectLinkable old_linkable)- -> return $ (UpToDate, Just old_linkable)- _ -> return $ (RecompBecause MissingBytecode, Nothing)+ -> UpToDateItem old_linkable+ _ -> outOfDateItemBecause MissingBytecode Nothing -------------------------------------------------------------- -- Compilers@@ -839,8 +852,7 @@ {- Note [ModDetails and --make mode]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ An interface file consists of two parts * The `ModIface` which ends up getting written to disk.@@ -947,17 +959,16 @@ -- We are not generating code, so we can skip simplification -- and generate a simple interface. _ -> do- (iface, mb_old_iface_hash, _details) <- liftIO $- hscSimpleIface hsc_env tc_result summary mb_old_hash+ (iface, _details) <- liftIO $+ hscSimpleIface hsc_env tc_result summary - liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_iface_hash (ms_location summary)+ liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary) return $ HscUpdate iface {- Note [Writing interface files] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- We write one interface file per module and per compilation, except with -dynamic-too where we write two interface files (non-dynamic and dynamic). @@ -999,7 +1010,18 @@ -} -- | Write interface files-hscMaybeWriteIface :: Logger -> DynFlags -> Bool -> ModIface -> Maybe Fingerprint -> ModLocation -> IO ()+hscMaybeWriteIface+ :: Logger+ -> DynFlags+ -> Bool+ -- ^ Is this a simple interface generated after the core pipeline, or one+ -- with information from the backend? See: Note [Writing interface files]+ -> ModIface+ -> Maybe Fingerprint+ -- ^ The old interface hash, used to decide if we need to actually write the+ -- new interface.+ -> ModLocation+ -> IO () hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do let force_write_interface = gopt Opt_WriteInterface dflags write_interface = case backend dflags of@@ -1019,41 +1041,41 @@ if (write_interface || force_write_interface) then do - -- FIXME: with -dynamic-too, "no_change" is only meaningful for the+ -- FIXME: with -dynamic-too, "change" is only meaningful for the -- non-dynamic interface, not for the dynamic one. We should have another -- flag for the dynamic interface. In the meantime: -- -- * when we write a single full interface, we check if we are -- currently writing the dynamic interface due to -dynamic-too, in- -- which case we ignore "no_change".+ -- which case we ignore "change". -- -- * when we write two simple interfaces at once because of- -- dynamic-too, we use "no_change" both for the non-dynamic and the+ -- dynamic-too, we use "change" both for the non-dynamic and the -- dynamic interfaces. Hopefully both the dynamic and the non-dynamic -- interfaces stay in sync... --- let no_change = old_iface == Just (mi_iface_hash (mi_final_exts iface))+ let change = old_iface /= Just (mi_iface_hash (mi_final_exts iface)) let dt = dynamicTooState dflags when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger $ hang (text "Writing interface(s):") 2 $ vcat [ text "Kind:" <+> if is_simple then text "simple" else text "full"- , text "Hash change:" <+> ppr (not no_change)+ , text "Hash change:" <+> ppr change , text "DynamicToo state:" <+> text (show dt) ] if is_simple- then unless no_change $ do -- FIXME: see no_change' comment above+ then when change $ do -- FIXME: see 'change' comment above write_iface dflags iface case dt of DT_Dont -> return () DT_Dyn -> panic "Unexpected DT_Dyn state when writing simple interface" DT_OK -> write_iface (setDynamicNow dflags) iface else case dt of- DT_Dont | not no_change -> write_iface dflags iface- DT_OK | not no_change -> write_iface dflags iface- -- FIXME: see no_change' comment above+ DT_Dont | change -> write_iface dflags iface+ DT_OK | change -> write_iface dflags iface+ -- FIXME: see change' comment above DT_Dyn -> write_iface dflags iface _ -> return () @@ -1113,7 +1135,7 @@ oneShotMsg logger recomp = case recomp of UpToDate -> compilationProgressMsg logger $ text "compilation IS NOT required"- _ -> return ()+ NeedsRecompile _ -> return () batchMsg :: Messager batchMsg = batchMsgWith (\_ _ _ _ -> empty)@@ -1123,12 +1145,12 @@ batchMsgWith :: (HscEnv -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc) -> Messager batchMsgWith extra hsc_env_start mod_index recomp node = case recomp of- MustCompile -> showMsg (text herald) empty UpToDate | logVerbAtLeast logger 2 -> showMsg (text "Skipping") empty | otherwise -> return ()- RecompBecause reason -> showMsg (text herald)- (text " [" <> pprWithUnitState state (ppr reason) <> text "]")+ NeedsRecompile reason0 -> showMsg (text herald) $ case reason0 of+ MustCompile -> empty+ (RecompBecause reason) -> text " [" <> pprWithUnitState state (ppr reason) <> text "]" where herald = case node of LinkNode {} -> "Linking"@@ -1539,7 +1561,7 @@ hsc_env <- getHscEnv hsc_env_with_plugins <- if null plugins -- fast path then return hsc_env- else liftIO $ flip initializePlugins (Just $ mg_mnwib ds_result)+ else liftIO $ initializePlugins $ hscUpdateFlags (\dflags -> foldr addPluginModuleName dflags plugins) hsc_env {-# SCC "Core2Core" #-}@@ -1554,16 +1576,14 @@ hscSimpleIface :: HscEnv -> TcGblEnv -> ModSummary- -> Maybe Fingerprint- -> IO (ModIface, Maybe Fingerprint, ModDetails)-hscSimpleIface hsc_env tc_result summary mb_old_iface- = runHsc hsc_env $ hscSimpleIface' tc_result summary mb_old_iface+ -> IO (ModIface, ModDetails)+hscSimpleIface hsc_env tc_result summary+ = runHsc hsc_env $ hscSimpleIface' tc_result summary hscSimpleIface' :: TcGblEnv -> ModSummary- -> Maybe Fingerprint- -> Hsc (ModIface, Maybe Fingerprint, ModDetails)-hscSimpleIface' tc_result summary mb_old_iface = do+ -> Hsc (ModIface, ModDetails)+hscSimpleIface' tc_result summary = do hsc_env <- getHscEnv logger <- getLogger details <- liftIO $ mkBootModDetailsTc logger tc_result@@ -1574,7 +1594,7 @@ mkIfaceTc hsc_env safe_mode details summary tc_result -- And the answer is ... liftIO $ dumpIfaceStats hsc_env- return (new_iface, mb_old_iface, details)+ return (new_iface, details) -------------------------------------------------------------- -- BackEnd combinators@@ -1582,7 +1602,7 @@ -- | Compile to hard-code. hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath- -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], CgInfos)+ -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe CgInfos) -- ^ @Just f@ <=> _stub.c is f hscGenHardCode hsc_env cgguts location output_filename = do let CgGuts{ -- This is the last use of the ModGuts in a compilation.@@ -1659,7 +1679,7 @@ <- {-# SCC "codeOutput" #-} codeOutput logger tmpfs dflags (hsc_units hsc_env) this_mod output_filename location foreign_stubs foreign_files dependencies rawcmms1- return (output_filename, stub_c_exists, foreign_fps, cg_infos)+ return (output_filename, stub_c_exists, foreign_fps, Just cg_infos) hscInteractive :: HscEnv@@ -1762,7 +1782,6 @@ {- Note [Forcing of stg_binds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~- The two last steps in the STG pipeline are: * Sorting the bindings in dependency order.@@ -1793,16 +1812,21 @@ tmpfs = hsc_tmpfs hsc_env platform = targetPlatform dflags - putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs)+ -- Do tag inference on optimized STG+ (!stg_post_infer,export_tag_info) <-+ {-# SCC "StgTagFields" #-} inferTags dflags logger this_mod stg_binds_w_fvs + putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG+ (pprGenStgTopBindings (initStgPprOpts dflags) stg_post_infer)+ let stg_to_cmm dflags mod = case stgToCmmHook hooks of Nothing -> StgToCmm.codeGen logger tmpfs (initStgToCmmConfig dflags mod) Just h -> h (initStgToCmmConfig dflags mod) let cmm_stream :: Stream IO CmmGroup ModuleLFInfos -- See Note [Forcing of stg_binds]- cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}- stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_binds_w_fvs hpc_info+ cmm_stream = stg_post_infer `seqList` {-# SCC "StgToCmm" #-}+ stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_post_infer hpc_info -- codegen consumes a stream of CmmGroup, and produces a new -- stream of CmmGroup (not necessarily synchronised: one@@ -1831,7 +1855,7 @@ putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a) return a - return $ Stream.mapM dump2 $ generateCgIPEStub hsc_env this_mod denv pipeline_stream+ return $ Stream.mapM dump2 $ generateCgIPEStub hsc_env this_mod denv export_tag_info pipeline_stream myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext -> Bool@@ -1870,8 +1894,12 @@ stg_binds_with_fvs <- {-# SCC "Stg2Stg" #-}- stg2stg logger dflags ictxt for_bytecode this_mod stg_binds+ stg2stg logger ictxt (initStgPipelineOpts dflags for_bytecode)+ this_mod stg_binds + putDumpFileMaybe logger Opt_D_dump_stg_cg "CodeGenInput STG:" FormatSTG+ (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_with_fvs)+ return (stg_binds_with_fvs, denv, cost_centre_info) {- **********************************************************************@@ -1936,7 +1964,7 @@ -- for linking, else we try to link 'main' and can't find it. -- Whereas the linker already knows to ignore 'interactive' let src_span = srcLocSpan interactiveSrcLoc- hval <- liftIO $ hscCompileCoreExpr hsc_env (src_span, Nothing) ds_expr+ (hval,_,_) <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr return $ Just (ids, hval, fix_env) @@ -2033,10 +2061,10 @@ stg_binds data_tycons mod_breaks let src_span = srcLocSpan interactiveSrcLoc- _ <- liftIO $ loadDecls interp hsc_env (src_span, Nothing) cbc+ _ <- liftIO $ loadDecls interp hsc_env src_span cbc {- Load static pointer table entries -}- liftIO $ hscAddSptEntries hsc_env Nothing (cg_spt_entries tidy_cg)+ liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg) let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg) patsyns = mg_patsyns simpl_mg@@ -2061,19 +2089,19 @@ -- | Load the given static-pointer table entries into the interpreter. -- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".-hscAddSptEntries :: HscEnv -> Maybe ModuleNameWithIsBoot -> [SptEntry] -> IO ()-hscAddSptEntries hsc_env mnwib entries = do+hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()+hscAddSptEntries hsc_env entries = do let interp = hscInterp hsc_env let add_spt_entry :: SptEntry -> IO () add_spt_entry (SptEntry i fpr) = do- val <- loadName interp hsc_env mnwib (idName i)+ -- These are only names from the current module+ (val, _, _) <- loadName interp hsc_env (idName i) addSptEntry interp fpr val mapM_ add_spt_entry entries {- Note [Fixity declarations in GHCi] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- To support fixity declarations on types defined within GHCi (as requested in #10018) we record the fixity environment in InteractiveContext. When we want to evaluate something GHC.Tc.Module.runTcInteractive pulls out this@@ -2177,13 +2205,13 @@ %* * %********************************************************************* -} -hscCompileCoreExpr :: HscEnv -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> CoreExpr -> IO ForeignHValue+hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded) hscCompileCoreExpr hsc_env loc expr = case hscCompileCoreExprHook (hsc_hooks hsc_env) of Nothing -> hscCompileCoreExpr' hsc_env loc expr Just h -> h hsc_env loc expr -hscCompileCoreExpr' :: HscEnv -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> CoreExpr -> IO ForeignHValue+hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded) hscCompileCoreExpr' hsc_env srcspan ds_expr = do { {- Simplify it -} -- Question: should we call SimpleOpt.simpleOptExpr here instead?@@ -2222,10 +2250,10 @@ [] Nothing {- load it -}- ; fv_hvs <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos+ ; (fv_hvs, mods_needed, units_needed) <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos {- Get the HValue for the root -} ; return (expectJust "hscCompileCoreExpr'"- $ lookup (idName binding_id) fv_hvs) }+ $ lookup (idName binding_id) fv_hvs, mods_needed, units_needed) } {- **********************************************************************
compiler/GHC/Driver/Make.hs view
@@ -2,8 +2,6 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -16,8 +14,9 @@ {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-} -- ----------------------------------------------------------------------------- --@@ -64,6 +63,7 @@ import GHC.Linker.Types import GHC.Runtime.Context+import GHC.Platform.Ways import GHC.Driver.Config.Finder (initFinderOpts) import GHC.Driver.Config.Parser (initParserOpts)@@ -82,7 +82,7 @@ import GHC.Iface.Load ( cannotFindModule ) import GHC.IfaceToCore ( typecheckIface )-import GHC.Iface.Recomp ( RecompileRequired ( MustCompile ) )+import GHC.Iface.Recomp ( RecompileRequired(..), CompileReason(..) ) import GHC.Data.Bag ( listToBag ) import GHC.Data.Graph.Directed@@ -116,9 +116,9 @@ import GHC.Unit.Finder import GHC.Unit.Module.ModSummary import GHC.Unit.Module.ModIface-import GHC.Unit.Module.ModDetails import GHC.Unit.Module.Graph import GHC.Unit.Home.ModInfo+import GHC.Unit.Module.ModDetails import Data.Either ( rights, partitionEithers, lefts ) import qualified Data.Map as Map@@ -447,7 +447,7 @@ else throwErrors (fmap GhcDriverMessage errs) -- Note [Unused packages]---+-- ~~~~~~~~~~~~~~~~~~~~~~ -- Cabal passes `--package-id` flag for each direct dependency. But GHC -- loads them lazily, so when compilation is done, we have a list of all -- actually loaded packages. All the packages, specified on command line,@@ -846,7 +846,6 @@ Note [--make mode] ~~~~~~~~~~~~~~~~~- There are two main parts to `--make` mode. 1. `downsweep`: Starts from the top of the module graph and computes dependencies.@@ -857,7 +856,6 @@ Note [Upsweep] ~~~~~~~~~~~~~~- Upsweep takes a 'ModuleGraph' as input, computes a build plan and then executes the plan in order to compile the project. @@ -1144,7 +1142,7 @@ -> IO () upsweep_inst hsc_env mHscMessage mod_index nmods uid iuid = do case mHscMessage of- Just hscMessage -> hscMessage hsc_env (mod_index, nmods) MustCompile (InstantiationNode uid iuid)+ Just hscMessage -> hscMessage hsc_env (mod_index, nmods) (NeedsRecompile MustCompile) (InstantiationNode uid iuid) Nothing -> return () runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ tcRnCheckUnit hsc_env $ VirtUnit iuid pure ()@@ -1168,16 +1166,15 @@ -- This function only does anything if the linkable produced is a BCO, which only happens with the -- bytecode backend, no need to guard against the backend type additionally. addSptEntries (hscUpdateHPT (\hpt -> addToHpt hpt (ms_mod_name summary) hmi) hsc_env)- (ms_mnwib summary) (hm_linkable hmi) return hmi -- | Add the entries from a BCO linkable to the SPT table, see -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.-addSptEntries :: HscEnv -> ModuleNameWithIsBoot -> Maybe Linkable -> IO ()-addSptEntries hsc_env mnwib mlinkable =- hscAddSptEntries hsc_env (Just mnwib)+addSptEntries :: HscEnv -> Maybe Linkable -> IO ()+addSptEntries hsc_env mlinkable =+ hscAddSptEntries hsc_env [ spt | Just linkable <- [mlinkable] , unlinked <- linkableUnlinked linkable@@ -1448,9 +1445,7 @@ -- for dependencies of modules that have -XTemplateHaskell, -- otherwise those modules will fail to compile. -- See Note [-fno-code mode] #8025- th_enabled_nodes <- case backend dflags of- NoBackend -> enableCodeGenForTH logger tmpfs unit_env all_nodes- _ -> return all_nodes+ th_enabled_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes if null all_root_errs then return (all_errs, th_enabled_nodes) else pure $ (all_root_errs, [])@@ -1464,7 +1459,6 @@ calcDeps ms = [(ms_unitid ms, b, c) | (b, c) <- msDeps ms ] - dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env roots = hsc_targets hsc_env @@ -1651,14 +1645,8 @@ -> [ModuleGraphNode] -> IO [ModuleGraphNode] enableCodeGenForTH logger tmpfs unit_env =- enableCodeGenWhen logger tmpfs condition should_modify TFL_CurrentModule TFL_GhcSession unit_env+ enableCodeGenWhen logger tmpfs TFL_CurrentModule TFL_GhcSession unit_env where- condition = isTemplateHaskellOrQQNonBoot- should_modify ms@(ModSummary { ms_hspp_opts = dflags }) =- backend dflags == NoBackend &&- -- Don't enable codegen for TH on indefinite packages; we- -- can't compile anything anyway! See #16219.- isHomeUnitDefinite (ue_unitHomeUnit (ms_unitid ms) unit_env) -- | Helper used to implement 'enableCodeGenForTH'. -- In particular, this enables@@ -1669,14 +1657,12 @@ enableCodeGenWhen :: Logger -> TmpFs- -> (ModSummary -> Bool)- -> (ModSummary -> Bool) -> TempFileLifetime -> TempFileLifetime -> UnitEnv -> [ModuleGraphNode] -> IO [ModuleGraphNode]-enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife unit_env mod_graph =+enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = mapM enable_code_gen mod_graph where defaultBackendOf ms = platformDefaultBackend (targetPlatform $ ue_unitFlags (ms_unitid ms) unit_env)@@ -1687,38 +1673,87 @@ , ms_hsc_src = HsSrcFile , ms_hspp_opts = dflags } <- ms- , should_modify ms- , mkNodeKey n `Set.member` needs_codegen_set- = do- let new_temp_file suf dynsuf = do- tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf- let dyn_tn = tn -<.> dynsuf- addFilesToClean tmpfs dynLife [dyn_tn]- return (tn, dyn_tn)- -- We don't want to create .o or .hi files unless we have been asked- -- to by the user. But we need them, so we patch their locations in- -- the ModSummary with temporary files.- --- ((hi_file, dyn_hi_file), (o_file, dyn_o_file)) <-- -- If ``-fwrite-interface` is specified, then the .o and .hi files- -- are written into `-odir` and `-hidir` respectively. #16670- if gopt Opt_WriteInterface dflags- then return ((ml_hi_file ms_location, ml_dyn_hi_file ms_location)- , (ml_obj_file ms_location, ml_dyn_obj_file ms_location))- else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))- <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))- let ms' = ms- { ms_location =- ms_location { ml_hi_file = hi_file- , ml_obj_file = o_file- , ml_dyn_hi_file = dyn_hi_file- , ml_dyn_obj_file = dyn_o_file }- , ms_hspp_opts = updOptLevel 0 $ dflags {backend = defaultBackendOf ms}- }- pure (ModuleNode deps ms')+ , mkNodeKey n `Set.member` needs_codegen_set =+ if | nocode_enable ms -> do+ let new_temp_file suf dynsuf = do+ tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf+ let dyn_tn = tn -<.> dynsuf+ addFilesToClean tmpfs dynLife [dyn_tn]+ return (tn, dyn_tn)+ -- We don't want to create .o or .hi files unless we have been asked+ -- to by the user. But we need them, so we patch their locations in+ -- the ModSummary with temporary files.+ --+ ((hi_file, dyn_hi_file), (o_file, dyn_o_file)) <-+ -- If ``-fwrite-interface` is specified, then the .o and .hi files+ -- are written into `-odir` and `-hidir` respectively. #16670+ if gopt Opt_WriteInterface dflags+ then return ((ml_hi_file ms_location, ml_dyn_hi_file ms_location)+ , (ml_obj_file ms_location, ml_dyn_obj_file ms_location))+ else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))+ <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))+ let ms' = ms+ { ms_location =+ ms_location { ml_hi_file = hi_file+ , ml_obj_file = o_file+ , ml_dyn_hi_file = dyn_hi_file+ , ml_dyn_obj_file = dyn_o_file }+ , ms_hspp_opts = updOptLevel 0 $ dflags {backend = defaultBackendOf ms}+ }+ -- Recursive call to catch the other cases+ enable_code_gen (ModuleNode deps ms')+ | dynamic_too_enable ms -> do+ let ms' = ms+ { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_BuildDynamicToo+ }+ -- Recursive call to catch the other cases+ enable_code_gen (ModuleNode deps ms')+ | ext_interp_enable ms -> do+ let ms' = ms+ { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ExternalInterpreter+ }+ -- Recursive call to catch the other cases+ enable_code_gen (ModuleNode deps ms')++ | otherwise -> return n+ enable_code_gen ms = return ms + nocode_enable ms@(ModSummary { ms_hspp_opts = dflags }) =+ backend dflags == NoBackend &&+ -- Don't enable codegen for TH on indefinite packages; we+ -- can't compile anything anyway! See #16219.+ isHomeUnitDefinite (ue_unitHomeUnit (ms_unitid ms) unit_env) + -- #8180 - when using TemplateHaskell, switch on -dynamic-too so+ -- the linker can correctly load the object files. This isn't necessary+ -- when using -fexternal-interpreter.+ dynamic_too_enable ms+ = hostIsDynamic && internalInterpreter &&+ not isDynWay && not isProfWay && not dyn_too_enabled+ where+ lcl_dflags = ms_hspp_opts ms+ internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)+ dyn_too_enabled = (gopt Opt_BuildDynamicToo lcl_dflags)+ isDynWay = hasWay (ways lcl_dflags) WayDyn+ isProfWay = hasWay (ways lcl_dflags) WayProf++ -- #16331 - when no "internal interpreter" is available but we+ -- need to process some TemplateHaskell or QuasiQuotes, we automatically+ -- turn on -fexternal-interpreter.+ ext_interp_enable ms = not host_internalInterpreter && internalInterpreter+ where+ lcl_dflags = ms_hspp_opts ms+#if defined(HAVE_INTERNAL_INTERPRETER)+ host_internalInterpreter = True+#else+ host_internalInterpreter = False+#endif+ internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)++++ (mg, lookup_node) = moduleGraphNodes False mod_graph needs_codegen_set = Set.fromList $ map (mkNodeKey . node_payload) $ reachablesG mg (map (expectJust "needs_th" . lookup_node) has_th_set) @@ -1726,7 +1761,7 @@ has_th_set = [ mkNodeKey mn | mn@(ModuleNode _ ms) <- mod_graph- , condition ms+ , isTemplateHaskellOrQQNonBoot ms ] -- | Populate the Downsweep cache with the root modules.@@ -2400,7 +2435,7 @@ g = ...f... ``` -## Why we need to rehydrate A's ModIface before compiling R.hs+== Why we need to rehydrate A's ModIface before compiling R.hs After compiling A.hs we'll have a TypeEnv in which the Id for `f` has a type type uses the AbstractTyCon T; and a TyCon for `S` that also mentions that same@@ -2420,7 +2455,7 @@ for `T`; see [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot). But note that this must be done *before* compiling R.hs. -## Why we need to rehydrate A's ModIface after compiling R.hs+== Why we need to rehydrate A's ModIface after compiling R.hs When compiling R.hs, the knot-tying stuff above will ensure that `f`'s unfolding mentions the `LocalId` for `g`. But when we finish R, we carefully ensure that@@ -2431,7 +2466,7 @@ Solution: rehydrate both R and A's ModIface together, right after completing R.hs. -## Which modules to rehydrate+~~ Which modules to rehydrate We only need rehydrate modules that are * Below R.hs@@ -2440,7 +2475,7 @@ There might be many unrelated modules (in the home package) that don't need to be rehydrated. -## Modules "above" the loop+== Modules "above" the loop This dark corner is the subject of #14092. @@ -2520,10 +2555,12 @@ runPipelines :: Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()+-- Don't even initialise plugins if there are no pipelines+runPipelines _ _ _ [] = return () runPipelines n_job orig_hsc_env mHscMessager all_pipelines = do liftIO $ label_self "main --make thread" - plugins_hsc_env <- initializePlugins orig_hsc_env Nothing+ plugins_hsc_env <- initializePlugins orig_hsc_env case n_job of 1 -> runSeqPipelines plugins_hsc_env mHscMessager all_pipelines _n -> runParPipelines n_job plugins_hsc_env mHscMessager all_pipelines@@ -2638,7 +2675,7 @@ waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar {- Note [GHC Heap Invariants]-+ ~~~~~~~~~~~~~~~~~~~~~~~~~~ This note is a general place to explain some of the heap invariants which should hold for a program compiled with --make mode. These invariants are all things which can be checked easily using ghc-debug.
compiler/GHC/Driver/Pipeline.hs view
@@ -108,7 +108,6 @@ --import GHC.Unit.State import GHC.Unit.Module.ModSummary import GHC.Unit.Module.ModIface-import GHC.Unit.Module.Graph (needsTemplateHaskellOrQQ) import GHC.Unit.Module.Deps import GHC.Unit.Home.ModInfo @@ -238,7 +237,7 @@ addFilesToClean tmpfs TFL_GhcSession $ [ml_obj_file $ ms_location summary] - plugin_hsc_env <- initializePlugins hsc_env (Just (ms_mnwib summary))+ plugin_hsc_env <- initializePlugins hsc_env let pipe_env = mkPipeEnv NoStop input_fn pipelineOutput status <- hscRecompStatus mHscMessage plugin_hsc_env upd_summary mb_old_iface mb_old_linkable (mod_index, nmods)@@ -252,11 +251,6 @@ location = ms_location summary input_fn = expectJust "compile:hs" (ml_hs_file location) input_fnpp = ms_hspp_file summary- mod_graph = hsc_mod_graph hsc_env0- needsLinker = needsTemplateHaskellOrQQ mod_graph- isDynWay = hasWay (ways lcl_dflags) WayDyn- isProfWay = hasWay (ways lcl_dflags) WayProf- internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags) pipelineOutput = case bcknd of Interpreter -> NoOutputFile@@ -266,28 +260,13 @@ logger = hsc_logger hsc_env0 tmpfs = hsc_tmpfs hsc_env0 - -- #8180 - when using TemplateHaskell, switch on -dynamic-too so- -- the linker can correctly load the object files. This isn't necessary- -- when using -fexternal-interpreter.- dflags1 = if hostIsDynamic && internalInterpreter &&- not isDynWay && not isProfWay && needsLinker- then gopt_set lcl_dflags Opt_BuildDynamicToo- else lcl_dflags-- -- #16331 - when no "internal interpreter" is available but we- -- need to process some TemplateHaskell or QuasiQuotes, we automatically- -- turn on -fexternal-interpreter.- dflags2 = if not internalInterpreter && needsLinker- then gopt_set dflags1 Opt_ExternalInterpreter- else dflags1- basename = dropExtension input_fn -- We add the directory in which the .hs files resides) to the import -- path. This is needed when we try to compile the .hc file later, if it -- imports a _stub.h file that we created here. current_dir = takeDirectory basename- old_paths = includePaths dflags2+ old_paths = includePaths lcl_dflags loadAsByteCode | Just Target { targetAllowObjCode = obj } <- findTarget summary (hsc_targets hsc_env0) , not obj@@ -300,10 +279,10 @@ -- was set), force it to generate byte-code. This is NOT transitive and -- only applies to direct targets. | loadAsByteCode- = (Interpreter, gopt_set (dflags2 { backend = Interpreter }) Opt_ForceRecomp)+ = (Interpreter, gopt_set (lcl_dflags { backend = Interpreter }) Opt_ForceRecomp) | otherwise- = (backend dflags, dflags2)- -- Note [Filepaths and Multiple Home Units]+ = (backend dflags, lcl_dflags)+ -- See Note [Filepaths and Multiple Home Units] dflags = dflags3 { includePaths = offsetIncludePaths dflags3 $ addImplicitQuoteInclude old_paths [current_dir] } upd_summary = summary { ms_hspp_opts = dflags } hsc_env = hscSetFlags dflags hsc_env0@@ -314,7 +293,6 @@ -- -- Note [Dynamic linking on macOS] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- Since macOS Sierra (10.14), the dynamic system linker enforces -- a limit on the Load Commands. Specifically the Load Command Size -- Limit is at 32K (32768). The Load Commands contain the install@@ -481,7 +459,7 @@ exe_file = exeFileName platform staticLink (outputFile_ dflags) e_exe_time <- tryIO $ getModificationUTCTime exe_file case e_exe_time of- Left _ -> return MustCompile+ Left _ -> return $ NeedsRecompile MustCompile Right t -> do -- first check object files and extra_ld_inputs let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]@@ -489,7 +467,7 @@ let (errs,extra_times) = partitionEithers e_extra_times let obj_times = map linkableTime linkables ++ extra_times if not (null errs) || any (t <) obj_times- then return (RecompBecause ObjectsChanged)+ then return $ needsRecompileBecause ObjectsChanged else do -- next, check libraries. XXX this only checks Haskell libraries,@@ -499,16 +477,16 @@ lib <- unitHsLibs (ghcNameVersion dflags) (ways dflags) c ] pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs- if any isNothing pkg_libfiles then return (RecompBecause LibraryChanged) else do+ if any isNothing pkg_libfiles then return $ needsRecompileBecause LibraryChanged else do e_lib_times <- mapM (tryIO . getModificationUTCTime) (catMaybes pkg_libfiles) let (lib_errs,lib_times) = partitionEithers e_lib_times if not (null lib_errs) || any (t <) lib_times- then return (RecompBecause LibraryChanged)+ then return $ needsRecompileBecause LibraryChanged else do res <- checkLinkInfo logger dflags unit_env pkg_deps exe_file if res- then return (RecompBecause FlagsChanged)+ then return $ needsRecompileBecause FlagsChanged else return UpToDate @@ -906,10 +884,8 @@ fromSuffix _ = return (Just input_fn) {-- Note [The Pipeline Monad] ~~~~~~~~~~~~~~~~~~~~~~~~~- The pipeline is represented as a free monad by the `TPipelineClass` type synonym, which stipulates the general monadic interface for the pipeline and `MonadUse`, instantiated to `TPhase`, which indicates the actions available in the pipeline.
compiler/GHC/Driver/Pipeline/Execute.hs view
@@ -171,7 +171,7 @@ runLlvmLlcPhase :: PipeEnv -> HscEnv -> FilePath -> IO FilePath runLlvmLlcPhase pipe_env hsc_env input_fn = do -- Note [Clamping of llc optimizations]- --+ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- See #13724 -- -- we clamp the llc optimization between [1,2]. This is because passing -O0@@ -521,9 +521,9 @@ return ([], final_iface, Just linkable, panic "interpreter") _ -> do output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env (Just location)- (outputFilename, mStub, foreign_files, cg_infos) <-+ (outputFilename, mStub, foreign_files, mb_cg_infos) <- hscGenHardCode hsc_env cgguts mod_location output_fn- final_iface <- mkFullIface hsc_env partial_iface (Just cg_infos)+ final_iface <- mkFullIface hsc_env partial_iface mb_cg_infos -- See Note [Writing interface files] hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location@@ -671,7 +671,7 @@ -- run the compiler! let msg :: Messager msg hsc_env _ what _ = oneShotMsg (hsc_logger hsc_env) what- plugin_hsc_env' <- initializePlugins hsc_env (Just $ ms_mnwib mod_summary)+ plugin_hsc_env' <- initializePlugins hsc_env -- Need to set the knot-tying mutable variable for interface -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var.@@ -1077,7 +1077,6 @@ {- Note [Produce big objects on Windows] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- The Windows Portable Executable object format has a limit of 32k sections, which we tend to blow through pretty easily. Thankfully, there is a "big object" extension, which raises this limit to 2^32. However, it must be explicitly@@ -1272,7 +1271,7 @@ -- + 3c: R_SPARC_HI22 _GLOBAL_OFFSET_TABLE_-0x8 {- Note [Don't normalise input filenames]-+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Summary We used to normalise input filenames when starting the unlit phase. This broke hpc in `--make` mode with imported literate modules (#2991).
compiler/GHC/HsToCore.hs view
@@ -133,7 +133,8 @@ tcg_insts = insts, tcg_fam_insts = fam_insts, tcg_hpc = other_hpc_info,- tcg_complete_matches = complete_matches+ tcg_complete_matches = complete_matches,+ tcg_self_boot = self_boot }) = do { let dflags = hsc_dflags hsc_env@@ -149,7 +150,13 @@ ; (binds_cvr, ds_hpc_info, modBreaks) <- if not (isHsBootOrSig hsc_src)- then addTicksToBinds hsc_env mod mod_loc+ then addTicksToBinds+ (CoverageConfig+ { coverageConfig_logger = hsc_logger hsc_env+ , coverageConfig_dynFlags = hsc_dflags hsc_env+ , coverageConfig_mInterp = hsc_interp hsc_env+ })+ mod mod_loc export_set (typeEnvTyCons type_env) binds else return (binds, hpcInfo, Nothing) ; (msgs, mb_res) <- initDs hsc_env tcg_env $@@ -160,7 +167,7 @@ ; (ds_fords, foreign_prs) <- dsForeigns fords ; ds_rules <- mapMaybeM dsRule rules ; let hpc_init- | gopt Opt_Hpc dflags = hpcInitCode (hsc_dflags hsc_env) mod ds_hpc_info+ | gopt Opt_Hpc dflags = hpcInitCode (targetPlatform $ hsc_dflags hsc_env) mod ds_hpc_info | otherwise = mempty ; return ( ds_ev_binds , foreign_prs `appOL` core_prs `appOL` spec_prs@@ -206,9 +213,10 @@ ; used_th <- readIORef tc_splice_used ; dep_files <- readIORef dependent_files ; safe_mode <- finalSafeMode dflags tcg_env+ ; (needed_mods, needed_pkgs) <- readIORef (tcg_th_needed_deps tcg_env) - ; usages <- mkUsageInfo hsc_env mod hsc_src (imp_mods imports) used_names- dep_files merged+ ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names+ dep_files merged needed_mods needed_pkgs -- id_mod /= mod when we are processing an hsig, but hsigs -- never desugared and compiled (there's no code!) -- Consequently, this should hold for any ModGuts that make@@ -236,6 +244,7 @@ mg_fam_insts = fam_insts, mg_inst_env = inst_env, mg_fam_inst_env = fam_inst_env,+ mg_boot_exports = bootExports self_boot, mg_patsyns = patsyns, mg_rules = ds_rules_for_imps, mg_binds = ds_binds,
compiler/GHC/HsToCore/Coverage.hs view
@@ -9,14 +9,16 @@ (c) University of Glasgow, 2007 -} -module GHC.HsToCore.Coverage (addTicksToBinds, hpcInitCode) where+module GHC.HsToCore.Coverage+ ( CoverageConfig (..)+ , addTicksToBinds+ , hpcInitCode+ ) where import GHC.Prelude as Prelude import GHC.Driver.Session import GHC.Driver.Backend-import GHC.Driver.Ppr-import GHC.Driver.Env import qualified GHC.Runtime.Interpreter as GHCi import GHCi.RemoteTypes@@ -33,6 +35,10 @@ import GHC.Data.FastString import GHC.Data.Bag +import GHC.Platform++import GHC.Runtime.Interpreter.Types+ import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic@@ -72,8 +78,17 @@ ************************************************************************ -} +data CoverageConfig = CoverageConfig+ { coverageConfig_logger :: Logger++ -- FIXME: replace this with the specific fields of DynFlags we care about.+ , coverageConfig_dynFlags :: DynFlags++ , coverageConfig_mInterp :: Maybe Interp+ }+ addTicksToBinds- :: HscEnv+ :: CoverageConfig -> Module -> ModLocation -- ... off the current module -> NameSet -- Exported Ids. When we call addTicksToBinds,@@ -83,9 +98,13 @@ -> LHsBinds GhcTc -> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks) -addTicksToBinds hsc_env mod mod_loc exports tyCons binds- | let dflags = hsc_dflags hsc_env- passes = coveragePasses dflags+addTicksToBinds (CoverageConfig+ { coverageConfig_logger = logger+ , coverageConfig_dynFlags = dflags+ , coverageConfig_mInterp = m_interp+ })+ mod mod_loc exports tyCons binds+ | let passes = coveragePasses dflags , not (null passes) , Just orig_file <- ml_hs_file mod_loc = do @@ -95,7 +114,7 @@ let env = TTE { fileName = mkFastString orig_file2 , declPath = []- , tte_dflags = dflags+ , tte_countEntries = gopt Opt_ProfCountEntries dflags , exports = exports , inlines = emptyVarSet , inScope = emptyVarSet@@ -121,9 +140,8 @@ let tickCount = tickBoxCount st entries = reverse $ mixEntries st hashNo <- writeMixEntries dflags mod tickCount entries orig_file2- modBreaks <- mkModBreaks hsc_env mod tickCount entries+ modBreaks <- mkModBreaks m_interp dflags mod tickCount entries - let logger = hsc_logger hsc_env putDumpFileMaybe logger Opt_D_dump_ticked "HPC" FormatHaskell (pprLHsBinds binds1) @@ -144,12 +162,12 @@ _ -> orig_file -mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO (Maybe ModBreaks)-mkModBreaks hsc_env mod count entries- | Just interp <- hsc_interp hsc_env- , breakpointsEnabled (hsc_dflags hsc_env) = do+mkModBreaks :: Maybe Interp -> DynFlags -> Module -> Int -> [MixEntry_] -> IO (Maybe ModBreaks)+mkModBreaks m_interp dflags mod count entries+ | Just interp <- m_interp+ , breakpointsEnabled dflags = do breakArray <- GHCi.newBreakArray interp (length entries)- ccs <- mkCCSArray hsc_env mod count entries+ ccs <- mkCCSArray interp mod count entries let locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ] varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ]@@ -164,21 +182,18 @@ | otherwise = return Nothing mkCCSArray- :: HscEnv -> Module -> Int -> [MixEntry_]+ :: Interp -> Module -> Int -> [MixEntry_] -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))-mkCCSArray hsc_env modul count entries =- case hsc_interp hsc_env of- Just interp | GHCi.interpreterProfiled interp -> do+mkCCSArray interp modul count entries+ | GHCi.interpreterProfiled interp = do let module_str = moduleNameString (moduleName modul) costcentres <- GHCi.mkCostCentres interp module_str (map mk_one entries) return (listArray (0,count-1) costcentres)-- _ -> return (listArray (0,-1) [])+ | otherwise = return (listArray (0,-1) []) where- dflags = hsc_dflags hsc_env mk_one (srcspan, decl_path, _, _) = (name, src) where name = concat (intersperse "." decl_path)- src = showSDoc dflags (ppr srcspan)+ src = renderWithContext defaultSDocContext (ppr srcspan) writeMixEntries@@ -400,7 +415,7 @@ -- Note [inline sccs]---+-- ~~~~~~~~~~~~~~~~~~ -- The reason not to add ticks to INLINE functions is that this is -- sometimes handy for avoiding adding a tick to a particular function -- (see #6131)@@ -831,9 +846,8 @@ addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc) addTickIPBind (IPBind x nm e) =- liftM2 (IPBind x)- (return nm)- (addTickLHsExpr e)+ liftM (IPBind x nm)+ (addTickLHsExpr e) -- There is no location here, so we might need to use a context location?? addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)@@ -1035,7 +1049,9 @@ data TickTransEnv = TTE { fileName :: FastString , density :: TickDensity- , tte_dflags :: DynFlags+ , tte_countEntries :: !Bool+ -- ^ Whether the number of times functions are+ -- entered should be counted. , exports :: NameSet , inlines :: VarSet , declPath :: [String]@@ -1050,17 +1066,13 @@ data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes deriving (Eq) -sourceNotesEnabled :: DynFlags -> Bool-sourceNotesEnabled dflags =- (debugLevel dflags > 0) || (gopt Opt_InfoTableMap dflags)- coveragePasses :: DynFlags -> [TickishType] coveragePasses dflags = ifa (breakpointsEnabled dflags) Breakpoints $ ifa (gopt Opt_Hpc dflags) HpcTicks $ ifa (sccProfilingEnabled dflags && profAuto dflags /= NoProfAuto) ProfNotes $- ifa (sourceNotesEnabled dflags) SourceNotes []+ ifa (needSourceNotes dflags) SourceNotes [] where ifa f x xs | f = x:xs | otherwise = xs @@ -1080,6 +1092,7 @@ noFVs = emptyOccEnv -- Note [freevars]+-- ~~~~~~~~~~~~~~~ -- For breakpoints we want to collect the free variables of an -- expression for pinning on the HsTick. We don't want to collect -- *all* free variables though: in particular there's no point pinning@@ -1108,9 +1121,6 @@ (r2,fv2,st2) -> (r2, fv1 `plusOccEnv` fv2, st2) -instance HasDynFlags TM where- getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st)- -- | Get the next HPC cost centre index for a given centre name getCCIndexM :: FastString -> TM CostCentreIndex getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $@@ -1231,7 +1241,6 @@ cc_name | topOnly = head decl_path | otherwise = concat (intersperse "." decl_path) - dflags <- getDynFlags env <- getEnv case tickishType env of HpcTicks -> HpcTick (this_mod env) <$> addMixEntry me@@ -1240,7 +1249,7 @@ let nm = mkFastString cc_name flavour <- HpcCC <$> getCCIndexM nm let cc = mkUserCC nm (this_mod env) pos flavour- count = countEntries && gopt Opt_ProfCountEntries dflags+ count = countEntries && tte_countEntries env return $ ProfNote cc count True{-scopes-} Breakpoints -> Breakpoint noExtField <$> addMixEntry me <*> pure ids@@ -1331,9 +1340,9 @@ hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);} -} -hpcInitCode :: DynFlags -> Module -> HpcInfo -> CStub+hpcInitCode :: Platform -> Module -> HpcInfo -> CStub hpcInitCode _ _ (NoHpcInfo {}) = mempty-hpcInitCode dflags this_mod (HpcInfo tickCount hashNo)+hpcInitCode platform this_mod (HpcInfo tickCount hashNo) = CStub $ vcat [ text "static void hpc_init_" <> ppr this_mod <> text "(void) __attribute__((constructor));"@@ -1351,7 +1360,6 @@ ]) ] where- platform = targetPlatform dflags tickboxes = pprCLabel platform CStyle (mkHpcTicksLabel $ this_mod) module_name = hcat (map (text.charToC) $ BS.unpack $
compiler/GHC/HsToCore/Expr.hs view
@@ -103,7 +103,7 @@ ; foldrM ds_ip_bind inner ip_binds } where ds_ip_bind :: LIPBind GhcTc -> CoreExpr -> DsM CoreExpr- ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body+ ds_ip_bind (L _ (IPBind n _ e)) body = do e' <- dsLExpr e return (Let (NonRec n e') body) @@ -1042,7 +1042,6 @@ = do { ds_con <- dsHsConLike con ; ids <- newSysLocalsDs tys -- newSysLocalDs: /can/ be lev-poly; see- -- Note [Checking representation-polymorphic data constructors] ; return (mkLams tvs $ mkLams ids $ ds_con `mkTyApps` mkTyVarTys tvs
compiler/GHC/HsToCore/Foreign/Decl.hs view
@@ -684,6 +684,7 @@ foreignExportsInitialiser :: Module -> [Id] -> CStub+foreignExportsInitialiser _ [] = mempty foreignExportsInitialiser mod hs_fns = -- Initialise foreign exports by registering a stable pointer from an -- __attribute__((constructor)) function.
compiler/GHC/HsToCore/Match.hs view
@@ -254,7 +254,7 @@ maybeWarn $ filter (not . null) gs matchEmpty :: MatchId -> Type -> DsM (NonEmpty (MatchResult CoreExpr))--- See Note [Empty case expressions]+-- See Note [Empty case alternatives] matchEmpty var res_ty = return [MR_Fallible mk_seq] where@@ -343,7 +343,7 @@ error "empty case" or some such, because 'x' might be bound to (error "hello"), in which case we want to see that "hello" exception, not (error "empty case").-See also Note [Case elimination: lifted case] in GHC.Core.Opt.Simplify.+See also the "lifted case" discussion in Note [Case elimination] in GHC.Core.Opt.Simplify. ************************************************************************
compiler/GHC/HsToCore/Pmc/Desugar.hs view
@@ -74,7 +74,7 @@ -- where @b@ and @c@ are freshly allocated in @mkListGrds@ and @a@ is the match -- variable. mkListGrds :: Id -> [(Id, [PmGrd])] -> DsM [PmGrd]--- See Note [Order of guards matter] for why we need to intertwine guards+-- See Note [Order of guards matters] for why we need to intertwine guards -- on list elements. mkListGrds a [] = pure [vanillaConGrd a nilDataCon []] mkListGrds a ((x, head_grds):xs) = do
compiler/GHC/HsToCore/Pmc/Solver.hs view
@@ -1004,7 +1004,7 @@ oracle or doing inhabitation testing) contradictory. This implies a few invariants: * Whenever vi_pos overlaps with vi_neg according to 'eqPmAltCon', we refute.- This is implied by the Note [Pos/Neg invariant].+ This is implied by the Note [The Pos/Neg invariant]. * Whenever vi_neg subsumes a COMPLETE set, we refute. We consult vi_rcm to detect this, but we could just compare whole COMPLETE sets to vi_neg every time, if it weren't for performance.@@ -1496,7 +1496,7 @@ then pure subst else mzero -{- Note [Soundness and completeness]+{- Note [Soundness and Completeness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Soundness and completeness of the pattern-match checker depend entirely on the soundness and completeness of the inhabitation test.
compiler/GHC/HsToCore/Quote.hs view
@@ -462,7 +462,7 @@ repFamilyDecl (L loc fam) repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))- = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]+ = do { tc1 <- lookupLOcc tc -- See Note [Binders and occurrences] ; dec <- addTyClTyVarBinds tvs $ \bndrs -> repSynDecl tc1 bndrs rhs ; return (Just (locA loc, dec)) }@@ -470,7 +470,7 @@ repTyClD (L loc (DataDecl { tcdLName = tc , tcdTyVars = tvs , tcdDataDefn = defn }))- = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]+ = do { tc1 <- lookupLOcc tc -- See Note [Binders and occurrences] ; dec <- addTyClTyVarBinds tvs $ \bndrs -> repDataDefn tc1 (Left bndrs) defn ; return (Just (locA loc, dec)) }@@ -479,7 +479,7 @@ tcdTyVars = tvs, tcdFDs = fds, tcdSigs = sigs, tcdMeths = meth_binds, tcdATs = ats, tcdATDefs = atds }))- = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences]+ = do { cls1 <- lookupLOcc cls -- See Note [Binders and occurrences] ; dec <- addQTyVarBinds tvs $ \bndrs -> do { cxt1 <- repLContext cxt -- See Note [Scoped type variables in quotes]@@ -551,7 +551,7 @@ , fdTyVars = tvs , fdResultSig = L _ resultSig , fdInjectivityAnn = injectivity }))- = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]+ = do { tc1 <- lookupLOcc tc -- See Note [Binders and occurrences] ; let mkHsQTvs :: [LHsTyVarBndr () GhcRn] -> LHsQTyVars GhcRn mkHsQTvs tvs = HsQTvs { hsq_ext = [] , hsq_explicit = tvs }@@ -694,7 +694,7 @@ , feqn_pats = tys , feqn_fixity = fixity , feqn_rhs = rhs })- = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]+ = do { tc <- lookupLOcc tc_name -- See Note [Binders and occurrences] ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs -> do { tys1 <- case fixity of Prefix -> repTyArgs (repNamedTyCon tc) tys@@ -725,7 +725,7 @@ , feqn_pats = tys , feqn_fixity = fixity , feqn_rhs = defn }})- = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]+ = do { tc <- lookupLOcc tc_name -- See Note [Binders and occurrences] ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs -> do { tys1 <- case fixity of Prefix -> repTyArgs (repNamedTyCon tc) tys@@ -1844,11 +1844,8 @@ ; return (ss, core_list) } rep_implicit_param_bind :: LIPBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))-rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs)))- = do { name <- case ename of- Left (L _ n) -> rep_implicit_param_name n- Right _ ->- panic "rep_implicit_param_bind: post typechecking"+rep_implicit_param_bind (L loc (IPBind _ (L _ n) (L _ rhs)))+ = do { name <- rep_implicit_param_name n ; rhs' <- repE rhs ; ipb <- repImplicitParamBind name rhs' ; return (locA loc, ipb) }
compiler/GHC/HsToCore/Types.hs view
@@ -70,7 +70,7 @@ { dsl_meta :: DsMetaEnv -- ^ Template Haskell bindings , dsl_loc :: RealSrcSpan -- ^ To put in pattern-matching error msgs , dsl_nablas :: Nablas- -- ^ See Note [Note [Long-distance information] in "GHC.HsToCore.Pmc".+ -- ^ See Note [Long-distance information] in "GHC.HsToCore.Pmc". -- The set of reaching values Nablas is augmented as we walk inwards, refined -- through each pattern match in turn }
compiler/GHC/HsToCore/Usage.hs view
@@ -37,9 +37,9 @@ import qualified Data.Map as Map import GHC.Linker.Types-import GHC.Linker.Loader ( getLoaderState )-import GHC.Types.SourceFile import GHC.Unit.Finder+import GHC.Types.Unique.DFM+import GHC.Driver.Plugins {- Note [Module self-dependency] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -63,14 +63,14 @@ mkUsedNames :: TcGblEnv -> NameSet mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus -mkUsageInfo :: HscEnv -> Module -> HscSource -> ImportedMods -> NameSet -> [FilePath]- -> [(Module, Fingerprint)] -> IO [Usage]-mkUsageInfo hsc_env this_mod src dir_imp_mods used_names dependent_files merged+mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath]+ -> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded -> IO [Usage]+mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged needed_links needed_pkgs = do eps <- hscEPS hsc_env hashes <- mapM getFileHash dependent_files -- Dependencies on object files due to TH and plugins- object_usages <- mkObjectUsage (eps_PIT eps) hsc_env (GWIB (moduleName this_mod) (hscSourceToIsBoot src))+ object_usages <- mkObjectUsage (eps_PIT eps) hsc_env needed_links needed_pkgs let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod dir_imp_mods used_names usages = mod_usages ++ [ UsageFile { usg_file_path = f@@ -124,24 +124,38 @@ of the module and the implementation hashes of its dependencies, and then compare implementation hashes for recompilation. Creation of implementation hashes is however potentially expensive.++ A serious issue with the interface hash idea is that if you include an+ interface hash, that hash also needs to depend on the hash of its+ dependencies. Therefore, if any of the transitive dependencies of a modules+ gets updated then you need to recompile the module in case the interface+ hash has changed irrespective if the module uses TH or not.++ This is important to maintain the invariant that the information in the+ interface file is always up-to-date.+++ See #20790 (comment 3) -} +{-+Note [Object File Dependencies]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In addition to the Note [Plugin dependencies] above, for TH we also need to record+the hashes of object files that the TH code is required to load. These are+calculated by the loader in `getLinkDeps` and are accumulated in each individual+`TcGblEnv`, in `tcg_th_needed_deps`. We read this just before compute the UsageInfo+to inject the appropriate dependencies.+-}+ -- | Find object files corresponding to the transitive closure of given home -- modules and direct object files for pkg dependencies-mkObjectUsage :: PackageIfaceTable -> HscEnv -> ModuleNameWithIsBoot -> IO [Usage]-mkObjectUsage pit hsc_env mnwib = do- case hsc_interp hsc_env of- Just interp -> do- mps <- getLoaderState interp- case mps of- Just ps -> do- let ls = fromMaybe [] $ Map.lookup mnwib (module_deps ps)- ds = hs_objs_loaded ps- concat <$> sequence (map linkableToUsage ls ++ map librarySpecToUsage ds)- Nothing -> return []- Nothing -> return []--+mkObjectUsage :: PackageIfaceTable -> HscEnv -> [Linkable] -> PkgsLoaded -> IO [Usage]+mkObjectUsage pit hsc_env th_links_needed th_pkgs_needed = do+ let ls = ordNubOn linkableModule (th_links_needed ++ plugins_links_needed)+ ds = concatMap loaded_pkg_hs_objs $ eltsUDFM (plusUDFM th_pkgs_needed plugin_pkgs_needed) -- TODO possibly record loaded_pkg_non_hs_objs as well+ (plugins_links_needed, plugin_pkgs_needed) = loadedPluginDeps $ hsc_plugins hsc_env+ concat <$> sequence (map linkableToUsage ls ++ map librarySpecToUsage ds) where linkableToUsage (LM _ m uls) = mapM (unlinkedToUsage m) uls
compiler/GHC/HsToCore/Utils.hs view
@@ -183,7 +183,7 @@ runs on the output of the desugarer, so all is well by the end of the desugaring pass. -See also Note [MatchIds] in GHC.HsToCore.Match+See also Note [Match Ids] in GHC.HsToCore.Match ************************************************************************ * *
compiler/GHC/Iface/Ext/Ast.hs view
@@ -78,7 +78,7 @@ import Control.Applicative ( (<|>) ) {- Note [Updating HieAst for changes in the GHC AST]-+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When updating the code in this file for changes in the GHC AST, you need to pay attention to the following things: @@ -210,6 +210,7 @@ {- Note [Name Remapping]+ ~~~~~~~~~~~~~~~~~~~~~ The Typechecker introduces new names for mono names in AbsBinds. We don't care about the distinction between mono and poly bindings, so we replace all occurrences of the mono name with the poly name.@@ -415,6 +416,7 @@ concatM xs = concat <$> sequence xs {- Note [Capturing Scopes and other non local information]+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ toHie is a local transformation, but scopes of bindings cannot be known locally, hence we have to push the relevant info down into the binding nodes. We use the following types (*Context and *Scoped) to wrap things and@@ -459,6 +461,7 @@ deriving (Typeable, Data) -- Pattern Scope {- Note [TyVar Scopes]+ ~~~~~~~~~~~~~~~~~~~ Due to -XScopedTypeVariables, type variables can be in scope quite far from their original binding. We resolve the scope of these type variables in a separate pass@@ -512,6 +515,7 @@ map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs {- Note [Scoping Rules for SigPat]+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Explicitly quantified variables in pattern type signatures are not brought into scope in the rhs, but implicitly quantified variables are (HsWC and HsIB).@@ -1274,7 +1278,6 @@ valBinds ] - scopeHsLocaLBinds :: HsLocalBinds (GhcPass p) -> Scope scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs)) = foldr combineScopes NoScope (bsScope ++ sigsScope)@@ -1295,15 +1298,13 @@ = foldr combineScopes NoScope (map (mkScopeA . getLoc) bs) scopeHsLocaLBinds (EmptyLocalBinds _) = NoScope - instance HiePass p => ToHie (RScoped (LocatedA (IPBind (GhcPass p)))) where- toHie (RS scope (L sp bind)) = concatM $ makeNodeA bind sp : case bind of- IPBind _ (Left _) expr -> [toHie expr]- IPBind _ (Right v) expr ->- [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpanA sp))- $ L sp v- , toHie expr- ]+ toHie (RS scope (L sp bind@(IPBind v _ expr))) = concatM $ makeNodeA bind sp : case hiePass @p of+ HieRn -> [toHie expr]+ HieTc -> [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpanA sp))+ $ L sp v+ , toHie expr+ ] instance HiePass p => ToHie (RScoped (HsValBindsLR (GhcPass p) (GhcPass p))) where toHie (RS sc v) = concatM $ case v of
compiler/GHC/Iface/Make.hs view
@@ -46,6 +46,7 @@ import GHC.Core.Multiplicity import GHC.Core.InstEnv import GHC.Core.FamInstEnv+import GHC.Core.Ppr import GHC.Core.Unify( RoughMatchTc(..) ) import GHC.Driver.Env@@ -73,6 +74,7 @@ import GHC.Types.CompleteMatch import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Misc hiding ( eqListBy ) import GHC.Utils.Logger@@ -157,16 +159,19 @@ updateDecl :: [IfaceDecl] -> Maybe CgInfos -> [IfaceDecl] updateDecl decls Nothing = decls-updateDecl decls (Just CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf_infos }) = map update_decl decls+updateDecl decls (Just CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf_infos, cgTagSigs = tag_sigs })+ = map update_decl decls where update_decl (IfaceId nm ty details infos) | let not_caffy = elemNameSet nm non_cafs , let mb_lf_info = lookupNameEnv lf_infos nm- , warnPprTrace (isNothing mb_lf_info) "Name without LFInfo" (ppr nm) True+ , let sig = lookupNameEnv tag_sigs nm+ , warnPprTrace (isNothing mb_lf_info) "updateDecl" (text "Name without LFInfo:" <+> ppr nm) True -- Only allocate a new IfaceId if we're going to update the infos- , isJust mb_lf_info || not_caffy+ , isJust mb_lf_info || not_caffy || isJust sig = IfaceId nm ty details $- (if not_caffy then (HsNoCafRefs :) else id)+ (if not_caffy then (HsNoCafRefs :) else id) $+ (if isJust sig then (HsTagSig (fromJust sig):) else id) $ (case mb_lf_info of Nothing -> infos -- LFInfos not available when building .cmm files Just lf_info -> HsLFInfo (toIfaceLFInfo nm lf_info) : infos)@@ -206,6 +211,7 @@ let hpc_info = emptyHpcInfo other_hpc_info used_th <- readIORef tc_splice_used dep_files <- (readIORef dependent_files)+ (needed_links, needed_pkgs) <- readIORef (tcg_th_needed_deps tc_result) -- Do NOT use semantic module here; this_mod in mkUsageInfo -- is used solely to decide if we should record a dependency -- or not. When we instantiate a signature, the semantic@@ -213,8 +219,8 @@ -- but if you pass that in here, we'll decide it's the local -- module and does not need to be recorded as a dependency. -- See Note [Identity versus semantic module]- usages <- mkUsageInfo hsc_env this_mod hsc_src (imp_mods imports) used_names- dep_files merged+ usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names+ dep_files merged needed_links needed_pkgs (doc_hdr', doc_map, arg_map) <- extractDocs tc_result @@ -282,7 +288,7 @@ -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for more details. warns = src_warns iface_rules = map coreRuleToIfaceRule rules- iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts+ iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode (instEnvElts insts) iface_fam_insts = map famInstToIfaceFamInst fam_insts trust_info = setSafeMode safe_mode annotations = map mkIfaceAnnotation anns@@ -700,7 +706,9 @@ IfaceClsInst { ifDFun = idName dfun_id , ifOFlag = oflag , ifInstCls = cls_name- , ifInstTys = ifaceRoughMatchTcs rough_tcs+ , ifInstTys = ifaceRoughMatchTcs $ tail rough_tcs+ -- N.B. Drop the class name from the rough match template+ -- It is put back by GHC.Core.InstEnv.mkImportedInstance , ifInstOrph = orph } --------------------------@@ -728,14 +736,17 @@ ifaceRoughMatchTcs :: [RoughMatchTc] -> [Maybe IfaceTyCon] ifaceRoughMatchTcs tcs = map do_rough tcs where- do_rough OtherTc = Nothing- do_rough (KnownTc n) = Just (toIfaceTyCon_name n)+ do_rough RM_WildCard = Nothing+ do_rough (RM_KnownTc n) = Just (toIfaceTyCon_name n) -------------------------- coreRuleToIfaceRule :: CoreRule -> IfaceRule-coreRuleToIfaceRule (BuiltinRule { ru_fn = fn})- = pprTrace "toHsRule: builtin" (ppr fn) $- bogusIfaceRule fn+-- A plugin that installs a BuiltinRule in a CoreDoPluginPass should+-- ensure that there's another CoreDoPluginPass that removes the rule.+-- Otherwise a module using the plugin and compiled with -fno-omit-interface-pragmas+-- would cause panic when the rule is attempted to be written to the interface file.+coreRuleToIfaceRule rule@(BuiltinRule {})+ = pprPanic "toHsRule:" (pprRule rule) coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs,@@ -756,10 +767,3 @@ do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty)) do_arg (Coercion co) = IfaceCo (toIfaceCoercion co) do_arg arg = toIfaceExpr arg--bogusIfaceRule :: Name -> IfaceRule-bogusIfaceRule id_name- = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,- ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],- ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan,- ifRuleAuto = True }
compiler/GHC/Iface/Recomp.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-}@@ -6,7 +8,12 @@ module GHC.Iface.Recomp ( checkOldIface , RecompileRequired(..)+ , needsRecompileBecause+ , recompThen+ , MaybeValidated(..)+ , outOfDateItemBecause , RecompReason (..)+ , CompileReason(..) , recompileRequired , addFingerprints )@@ -111,17 +118,42 @@ -} data RecompileRequired+ -- | everything is up to date, recompilation is not required = UpToDate- -- ^ everything is up to date, recompilation is not required- | MustCompile- -- ^ The .hs file has been modified, or the .o/.hi file does not exist+ -- | Need to compile the module+ | NeedsRecompile !CompileReason+ deriving (Eq)++needsRecompileBecause :: RecompReason -> RecompileRequired+needsRecompileBecause = NeedsRecompile . RecompBecause++data MaybeValidated a+ -- | The item contained is validated to be up to date+ = UpToDateItem a+ -- | The item is are absent altogether or out of date, for the reason given.+ | OutOfDateItem+ !CompileReason+ -- ^ the reason we need to recompile.+ (Maybe a)+ -- ^ The old item, if it exists+ deriving (Functor)++outOfDateItemBecause :: RecompReason -> Maybe a -> MaybeValidated a+outOfDateItemBecause reason item = OutOfDateItem (RecompBecause reason) item++data CompileReason+ -- | The .hs file has been touched, or the .o/.hi file does not exist+ = MustCompile+ -- | The .o/.hi files are up to date, but something else has changed+ -- to force recompilation; the String says what (one-line summary) | RecompBecause !RecompReason- -- ^ The .o/.hi files are up to date, but something else has changed- -- to force recompilation; the String says what (one-line summary) deriving (Eq) instance Outputable RecompileRequired where ppr UpToDate = text "UpToDate"+ ppr (NeedsRecompile reason) = ppr reason++instance Outputable CompileReason where ppr MustCompile = text "MustCompile" ppr (RecompBecause r) = text "RecompBecause" <+> ppr r @@ -200,20 +232,30 @@ recompThen :: Monad m => m RecompileRequired -> m RecompileRequired -> m RecompileRequired recompThen ma mb = ma >>= \case- UpToDate -> mb- mc -> pure mc+ UpToDate -> mb+ rr@(NeedsRecompile _) -> pure rr +checkList :: Monad m => [m RecompileRequired] -> m RecompileRequired+checkList = \case+ [] -> return UpToDate+ (check : checks) -> check `recompThen` checkList checks++----------------------+ -- | Top level function to check if the version of an old interface file -- is equivalent to the current source file the user asked us to compile.--- If the same, we can avoid recompilation. We return a tuple where the--- first element is a bool saying if we should recompile the object file--- and the second is maybe the interface file, where Nothing means to--- rebuild the interface file and not use the existing one.+-- If the same, we can avoid recompilation.+--+-- We return on the outside whether the interface file is up to date, providing+-- evidence that is with a `ModIface`. In the case that it isn't, we may also+-- return a found or provided `ModIface`. Why we don't always return the old+-- one, if it exists, is unclear to me, except that I tried it and some tests+-- failed (see #18205). checkOldIface :: HscEnv -> ModSummary -> Maybe ModIface -- Old interface from compilation manager, if any- -> IO (RecompileRequired, Maybe ModIface)+ -> IO (MaybeValidated ModIface) checkOldIface hsc_env mod_summary maybe_iface = do let dflags = hsc_dflags hsc_env@@ -229,7 +271,7 @@ :: HscEnv -> ModSummary -> Maybe ModIface- -> IfG (RecompileRequired, Maybe ModIface)+ -> IfG (MaybeValidated ModIface) check_old_iface hsc_env mod_summary maybe_iface = let dflags = hsc_dflags hsc_env@@ -254,18 +296,18 @@ trace_if logger (text "Read the interface file" <+> text iface_path) return $ Just iface check_dyn_hi :: ModIface- -> IfG (RecompileRequired, Maybe a)- -> IfG (RecompileRequired, Maybe a)+ -> IfG (MaybeValidated ModIface)+ -> IfG (MaybeValidated ModIface) check_dyn_hi normal_iface recomp_check | gopt Opt_BuildDynamicToo dflags = do res <- recomp_check- case fst res of- UpToDate -> do+ case res of+ UpToDateItem _ -> do maybe_dyn_iface <- liftIO $ loadIface (setDynamicNow dflags) (msDynHiFilePath mod_summary) case maybe_dyn_iface of- Nothing -> return (RecompBecause MissingDynHiFile, Nothing)+ Nothing -> return $ outOfDateItemBecause MissingDynHiFile Nothing Just dyn_iface | mi_iface_hash (mi_final_exts dyn_iface) /= mi_iface_hash (mi_final_exts normal_iface)- -> return (RecompBecause MismatchedDynHiFile, Nothing)+ -> return $ outOfDateItemBecause MismatchedDynHiFile Nothing Just {} -> return res _ -> return res check_dyn_hi _ recomp_check = recomp_check@@ -283,19 +325,19 @@ -- avoid reading an interface; just return the one we might -- have been supplied with. True | not (backendProducesObject $ backend dflags) ->- return (MustCompile, maybe_iface)+ return $ OutOfDateItem MustCompile maybe_iface -- Try and read the old interface for the current module -- from the .hi file left from the last time we compiled it True -> do maybe_iface' <- liftIO $ getIface- return (MustCompile, maybe_iface')+ return $ OutOfDateItem MustCompile maybe_iface' False -> do maybe_iface' <- liftIO $ getIface case maybe_iface' of -- We can't retrieve the iface- Nothing -> return (MustCompile, Nothing)+ Nothing -> return $ OutOfDateItem MustCompile Nothing -- We have got the old iface; check its versions -- even in the SourceUnmodifiedAndStable case we@@ -318,7 +360,7 @@ checkVersions :: HscEnv -> ModSummary -> ModIface -- Old interface- -> IfG (RecompileRequired, Maybe ModIface)+ -> IfG (MaybeValidated ModIface) checkVersions hsc_env mod_summary iface = do { liftIO $ trace_hi_diffs logger (text "Considering whether compilation is required for" <+>@@ -329,20 +371,20 @@ -- test case bkpcabal04! ; hsc_env <- getTopEnv ; if mi_src_hash iface /= ms_hs_hash mod_summary- then return (RecompBecause SourceFileChanged, Nothing) else do {+ then return $ outOfDateItemBecause SourceFileChanged Nothing else do { ; if not (isHomeModule home_unit (mi_module iface))- then return (RecompBecause ThisUnitIdChanged, Nothing) else do {+ then return $ outOfDateItemBecause ThisUnitIdChanged Nothing else do { ; recomp <- liftIO $ checkFlagHash hsc_env iface `recompThen` checkOptimHash hsc_env iface `recompThen` checkHpcHash hsc_env iface `recompThen` checkMergedSignatures hsc_env mod_summary iface `recompThen` checkHsig logger home_unit mod_summary iface `recompThen` pure (checkHie dflags mod_summary)- ; if recompileRequired recomp then return (recomp, Nothing) else do {+ ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason Nothing ; _ -> do { ; recomp <- checkDependencies hsc_env mod_summary iface- ; if recompileRequired recomp then return (recomp, Just iface) else do {+ ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do { ; recomp <- checkPlugins (hsc_plugins hsc_env) iface- ; if recompileRequired recomp then return (recomp, Nothing) else do {+ ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason Nothing ; _ -> do { -- Source code unchanged and no errors yet... carry on@@ -360,8 +402,9 @@ } ; recomp <- checkList [checkModUsage (hsc_FC hsc_env) (homeUnitAsUnit home_unit) u | u <- mi_usages iface]- ; return (recomp, Just iface)- }}}}}}+ ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do {+ ; return $ UpToDateItem iface+ }}}}}}} where logger = hsc_logger hsc_env dflags = hsc_dflags hsc_env@@ -407,7 +450,7 @@ -- when we have an impure plugin in the stack we have to unconditionally -- recompile since it might integrate all sorts of crazy IO results into -- its compilation output.- ForceRecompile -> RecompBecause ImpurePlugin+ ForceRecompile -> needsRecompileBecause ImpurePlugin | old_fp `elem` magic_fingerprints || new_fp `elem` magic_fingerprints@@ -419,16 +462,16 @@ -- For example when we go from ForceRecomp to NoForceRecomp -- recompilation is triggered since the old impure plugins could have -- changed the build output which is now back to normal.- = RecompBecause PluginsChanged+ = needsRecompileBecause PluginsChanged | otherwise = case pr of -- even though a plugin is forcing recompilation the fingerprint changed -- which would cause recompilation anyways so we report the fingerprint -- change instead.- ForceRecompile -> RecompBecause PluginFingerprintChanged+ ForceRecompile -> needsRecompileBecause PluginFingerprintChanged - _ -> RecompBecause PluginFingerprintChanged+ _ -> needsRecompileBecause PluginFingerprintChanged where magic_fingerprints =@@ -446,7 +489,7 @@ massert (isHomeModule home_unit outer_mod) case inner_mod == mi_semantic_module iface of True -> up_to_date logger (text "implementing module unchanged")- False -> return (RecompBecause ModuleInstChanged)+ False -> return $ needsRecompileBecause ModuleInstChanged -- | Check if @.hie@ file is out of date or missing. checkHie :: DynFlags -> ModSummary -> RecompileRequired@@ -456,10 +499,10 @@ in if not (gopt Opt_WriteHie dflags) then UpToDate else case (hie_date_opt, hi_date) of- (Nothing, _) -> RecompBecause HieMissing+ (Nothing, _) -> needsRecompileBecause HieMissing (Just hie_date, Just hi_date) | hie_date < hi_date- -> RecompBecause HieOutdated+ -> needsRecompileBecause HieOutdated _ -> UpToDate -- | Check the flags haven't changed@@ -519,7 +562,7 @@ Just r -> sort $ map (instModuleToModule unit_state) r if old_merged == new_merged then up_to_date logger (text "signatures to merge in unchanged" $$ ppr new_merged)- else return (RecompBecause SigsMergeChanged)+ else return $ needsRecompileBecause SigsMergeChanged -- If the direct imports of this module are resolved to targets that -- are not among the dependencies of the previous interface file,@@ -537,21 +580,21 @@ res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary) res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary) case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of- Left recomp -> return recomp+ Left recomp -> return $ NeedsRecompile recomp Right es -> do let (hs, ps) = partitionEithers es- res1 <- liftIO $ check_mods (sort hs) prev_dep_mods-- let allPkgDeps = sortBy (comparing snd) $ nubOrdOn snd (ps ++ implicit_deps ++ bkpk_units)- res2 <- liftIO $ check_packages allPkgDeps prev_dep_pkgs- return (res1 `mappend` res2)+ liftIO $+ check_mods (sort hs) prev_dep_mods+ `recompThen`+ let allPkgDeps = sortBy (comparing snd) $ nubOrdOn snd (ps ++ implicit_deps ++ bkpk_units)+ in check_packages allPkgDeps prev_dep_pkgs where classify_import :: (ModuleName -> t -> IO FindResult) -> [(t, GenLocated l ModuleName)] -> IfG [Either- RecompileRequired (Either (UnitId, ModuleName) (String, UnitId))]+ CompileReason (Either (UnitId, ModuleName) (String, UnitId))] classify_import find_import imports = liftIO $ traverse (\(mb_pkg, L _ mod) -> let reason = ModuleChanged mod@@ -594,7 +637,7 @@ text "module no longer" <+> quotes (ppr old) <+> text "in dependencies" - return (RecompBecause (ModuleRemoved old))+ return $ needsRecompileBecause $ ModuleRemoved old check_mods (new:news) olds | Just (old, olds') <- uncons olds , new == old = check_mods (dropWhile (== new) news) olds'@@ -602,7 +645,7 @@ trace_hi_diffs logger $ text "imported module " <> quotes (ppr new) <> text " not among previous dependencies"- return (RecompBecause (ModuleAdded new))+ return $ needsRecompileBecause $ ModuleAdded new check_packages :: [(String, UnitId)] -> [UnitId] -> IO RecompileRequired check_packages [] [] = return UpToDate@@ -610,7 +653,7 @@ trace_hi_diffs logger $ text "package " <> quotes (ppr old) <> text "no longer in dependencies"- return (RecompBecause (UnitDepRemoved old))+ return $ needsRecompileBecause $ UnitDepRemoved old check_packages (new:news) olds | Just (old, olds') <- uncons olds , snd new == old = check_packages (dropWhile ((== (snd new)) . snd) news) olds'@@ -618,24 +661,22 @@ trace_hi_diffs logger $ text "imported package " <> quotes (ppr new) <> text " not among previous dependencies"- return (RecompBecause (ModulePackageChanged (fst new)))+ return $ needsRecompileBecause $ ModulePackageChanged $ fst new needInterface :: Module -> (ModIface -> IO RecompileRequired) -> IfG RecompileRequired needInterface mod continue = do- mb_recomp <- getFromModIface+ mb_recomp <- tryGetModIface "need version info for" mod- continue case mb_recomp of- Nothing -> return MustCompile- Just recomp -> return recomp+ Nothing -> return $ NeedsRecompile MustCompile+ Just iface -> liftIO $ continue iface -getFromModIface :: String -> Module -> (ModIface -> IO a)- -> IfG (Maybe a)-getFromModIface doc_msg mod getter+tryGetModIface :: String -> Module -> IfG (Maybe ModIface)+tryGetModIface doc_msg mod = do -- Load the imported interface if possible logger <- getLogger let doc_str = sep [text doc_msg, ppr mod]@@ -653,7 +694,7 @@ -- old interface file. Don't complain: it might -- just be that the current module doesn't need that -- import and it's been deleted- Succeeded iface -> Just <$> liftIO (getter iface)+ Succeeded iface -> pure $ Just iface -- | Given the usage information extracted from the old -- M.hi file for the module being compiled, figure out@@ -704,17 +745,15 @@ recompile <- checkModuleFingerprint logger reason old_mod_hash new_mod_hash if not (recompileRequired recompile) then return UpToDate- else- -- CHECK EXPORT LIST- checkMaybeHash logger reason maybe_old_export_hash new_export_hash- (text " Export list changed") $ do-- -- CHECK ITEMS ONE BY ONE- !recompile <- checkList [ checkEntityUsage logger reason new_decl_hash u- | u <- old_decl_hash]- if recompileRequired recompile- then return recompile -- This one failed, so just bail out now- else up_to_date logger (text " Great! The bits I use are up to date")+ else checkList+ [ -- CHECK EXPORT LIST+ checkMaybeHash logger reason maybe_old_export_hash new_export_hash+ (text " Export list changed")+ , -- CHECK ITEMS ONE BY ONE+ checkList [ checkEntityUsage logger reason new_decl_hash u+ | u <- old_decl_hash]+ , up_to_date logger (text " Great! The bits I use are up to date")+ ] checkModUsage fc _this_pkg UsageFile{ usg_file_path = file, usg_file_hash = old_hash,@@ -727,7 +766,7 @@ else return UpToDate where reason = FileChanged file- recomp = RecompBecause (fromMaybe reason (fmap CustomReason mlabel))+ recomp = needsRecompileBecause $ fromMaybe reason $ fmap CustomReason mlabel handler = if debugIsOn then \e -> pprTrace "UsageFile" (text (show e)) $ return recomp else \_ -> return recomp -- if we can't find the file, just recompile, don't fail@@ -769,12 +808,11 @@ -> Fingerprint -> SDoc -> IO RecompileRequired- -> IO RecompileRequired-checkMaybeHash logger reason maybe_old_hash new_hash doc continue+checkMaybeHash logger reason maybe_old_hash new_hash doc | Just hash <- maybe_old_hash, hash /= new_hash = out_of_date_hash logger reason doc hash new_hash | otherwise- = continue+ = return UpToDate ------------------------ checkEntityUsage :: Logger@@ -798,22 +836,12 @@ up_to_date logger msg = trace_hi_diffs logger msg >> return UpToDate out_of_date :: Logger -> RecompReason -> SDoc -> IO RecompileRequired-out_of_date logger reason msg = trace_hi_diffs logger msg >> return (RecompBecause reason)+out_of_date logger reason msg = trace_hi_diffs logger msg >> return (needsRecompileBecause reason) out_of_date_hash :: Logger -> RecompReason -> SDoc -> Fingerprint -> Fingerprint -> IO RecompileRequired out_of_date_hash logger reason msg old_hash new_hash = out_of_date logger reason (hsep [msg, ppr old_hash, text "->", ppr new_hash]) ------------------------checkList :: Monad m => [m RecompileRequired] -> m RecompileRequired--- This helper is used in two places-checkList [] = return UpToDate-checkList (check:checks) = do recompile <- check- if recompileRequired recompile- then return recompile- else checkList checks-- -- --------------------------------------------------------------------------- -- Compute fingerprints for the interface @@ -1474,6 +1502,7 @@ {- Note [default method Name] (see also #15970)+ ~~~~~~~~~~~~~~~~~~~~~~~~~~ The Names for the default methods aren't available in Iface syntax.
compiler/GHC/Iface/Recomp/Flags.hs view
@@ -48,7 +48,7 @@ map fromEnum $ EnumSet.toList extensionFlags) -- avoid fingerprinting the absolute path to the directory of the source file- -- see note [Implicit include paths]+ -- see Note [Implicit include paths] includePathsMinusImplicit = includePaths { includePathsQuoteImplicit = [] } -- -I, -D and -U flags affect CPP@@ -66,7 +66,7 @@ -- Ticky ticky =- map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk]+ map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk, Opt_Ticky_Tag] flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, debugLevel, callerCcFilters)) @@ -109,7 +109,7 @@ {- Note [path flags and recompilation]-+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There are several flags that we deliberately omit from the recompilation check; here we explain why. @@ -140,7 +140,6 @@ {- Note [Ignoring some flag changes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- Normally, --make tries to reuse only compilation products that are the same as those that would have been produced compiling from scratch. Sometimes, however, users would like to be more aggressive@@ -159,7 +158,6 @@ {- Note [Repeated -optP hashing] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- We invoke fingerprintDynFlags for each compiled module to include the hash of relevant DynFlags in the resulting interface file. -optP (preprocessor) flags are part of that hash.
compiler/GHC/Iface/Tidy.hs view
@@ -192,7 +192,7 @@ final_tcs = filterOut isWiredIn tcs -- See Note [Drop wired-in things] type_env' = typeEnvFromEntities final_ids final_tcs pat_syns fam_insts- insts' = mkFinalClsInsts type_env' insts+ insts' = mkFinalClsInsts type_env' $ mkInstEnv insts -- Default methods have their export flag set (isExportedId), -- but everything else doesn't (yet), because this is@@ -213,8 +213,8 @@ Just (AnId id') -> id' _ -> pprPanic "lookup_final_id" (ppr id) -mkFinalClsInsts :: TypeEnv -> [ClsInst] -> [ClsInst]-mkFinalClsInsts env = map (updateClsInstDFun (lookupFinalId env))+mkFinalClsInsts :: TypeEnv -> InstEnv -> InstEnv+mkFinalClsInsts env = updateClsInstDFuns (lookupFinalId env) globaliseAndTidyBootId :: Id -> Id -- For a LocalId with an External Name,@@ -365,6 +365,7 @@ , mg_foreign_files = foreign_files , mg_hpc_info = hpc_info , mg_modBreaks = modBreaks+ , mg_boot_exports = boot_exports }) = Err.withTiming logger@@ -384,7 +385,7 @@ ; let uf_opts = unfoldingOpts dflags ; (tidy_env, tidy_binds)- <- tidyTopBinds uf_opts unfold_env tidy_occ_env trimmed_binds+ <- tidyTopBinds uf_opts unfold_env boot_exports tidy_occ_env trimmed_binds -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. ; (spt_entries, tidy_binds') <-@@ -419,7 +420,7 @@ ; final_tcs = filterOut isWiredIn tcs -- See Note [Drop wired-in things] ; tidy_type_env = typeEnvFromEntities final_ids final_tcs patsyns fam_insts- ; tidy_cls_insts = mkFinalClsInsts tidy_type_env cls_insts+ ; tidy_cls_insts = mkFinalClsInsts tidy_type_env $ mkInstEnv cls_insts ; tidy_rules = tidyRules tidy_env trimmed_rules ; -- See Note [Injecting implicit bindings]@@ -1180,39 +1181,41 @@ tidyTopBinds :: UnfoldingOpts -> UnfoldEnv+ -> NameSet -> TidyOccEnv -> CoreProgram -> IO (TidyEnv, CoreProgram) -tidyTopBinds uf_opts unfold_env init_occ_env binds+tidyTopBinds uf_opts unfold_env boot_exports init_occ_env binds = do let result = tidy init_env binds seqBinds (snd result) `seq` return result -- This seqBinds avoids a spike in space usage (see #13564) where init_env = (init_occ_env, emptyVarEnv) - tidy = mapAccumL (tidyTopBind uf_opts unfold_env)+ tidy = mapAccumL (tidyTopBind uf_opts unfold_env boot_exports) ------------------------ tidyTopBind :: UnfoldingOpts -> UnfoldEnv+ -> NameSet -> TidyEnv -> CoreBind -> (TidyEnv, CoreBind) -tidyTopBind uf_opts unfold_env+tidyTopBind uf_opts unfold_env boot_exports (occ_env,subst1) (NonRec bndr rhs) = (tidy_env2, NonRec bndr' rhs') where Just (name',show_unfold) = lookupVarEnv unfold_env bndr- (bndr', rhs') = tidyTopPair uf_opts show_unfold tidy_env2 name' (bndr, rhs)+ (bndr', rhs') = tidyTopPair uf_opts show_unfold boot_exports tidy_env2 name' (bndr, rhs) subst2 = extendVarEnv subst1 bndr bndr' tidy_env2 = (occ_env, subst2) -tidyTopBind uf_opts unfold_env (occ_env, subst1) (Rec prs)+tidyTopBind uf_opts unfold_env boot_exports (occ_env, subst1) (Rec prs) = (tidy_env2, Rec prs') where- prs' = [ tidyTopPair uf_opts show_unfold tidy_env2 name' (id,rhs)+ prs' = [ tidyTopPair uf_opts show_unfold boot_exports tidy_env2 name' (id,rhs) | (id,rhs) <- prs, let (name',show_unfold) = expectJust "tidyTopBind" $ lookupVarEnv unfold_env id@@ -1226,6 +1229,7 @@ ----------------------------------------------------------- tidyTopPair :: UnfoldingOpts -> Bool -- show unfolding+ -> NameSet -> TidyEnv -- The TidyEnv is used to tidy the IdInfo -- It is knot-tied: don't look at it! -> Name -- New name@@ -1237,14 +1241,17 @@ -- group, a variable late in the group might be mentioned -- in the IdInfo of one early in the group -tidyTopPair uf_opts show_unfold rhs_tidy_env name' (bndr, rhs)- = (bndr1, rhs1)+tidyTopPair uf_opts show_unfold boot_exports rhs_tidy_env name' (bndr, rhs)+ = -- pprTrace "tidyTop" (ppr name' <+> ppr details <+> ppr rhs) $+ (bndr1, rhs1)+ where+ !cbv_bndr = tidyCbvInfoTop boot_exports bndr rhs bndr1 = mkGlobalId details name' ty' idinfo'- details = idDetails bndr -- Preserve the IdDetails- ty' = tidyTopType (idType bndr)+ details = idDetails cbv_bndr -- Preserve the IdDetails+ ty' = tidyTopType (idType cbv_bndr) rhs1 = tidyExpr rhs_tidy_env rhs- idinfo' = tidyTopIdInfo uf_opts rhs_tidy_env name' rhs rhs1 (idInfo bndr)+ idinfo' = tidyTopIdInfo uf_opts rhs_tidy_env name' rhs rhs1 (idInfo cbv_bndr) show_unfold -- tidyTopIdInfo creates the final IdInfo for top-level@@ -1264,7 +1271,7 @@ `setArityInfo` arity `setDmdSigInfo` final_sig `setCprSigInfo` final_cpr- `setUnfoldingInfo` minimal_unfold_info -- See note [Preserve evaluatedness]+ `setUnfoldingInfo` minimal_unfold_info -- See Note [Preserve evaluatedness] -- in GHC.Core.Tidy | otherwise -- Externally-visible Ids get the whole lot
compiler/GHC/IfaceToCore.hs view
@@ -220,7 +220,7 @@ -- an example where this would cause non-termination. text "Type envt:" <+> ppr (map fst names_w_things)]) ; return $ ModDetails { md_types = type_env- , md_insts = insts+ , md_insts = mkInstEnv insts , md_fam_insts = fam_insts , md_rules = rules , md_anns = anns@@ -428,7 +428,7 @@ exports <- ifaceExportNames (mi_exports iface) complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface) return $ ModDetails { md_types = type_env- , md_insts = insts+ , md_insts = mkInstEnv insts , md_fam_insts = fam_insts , md_rules = rules , md_anns = anns@@ -467,7 +467,7 @@ exports <- ifaceExportNames (mi_exports iface) complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface) return $ ModDetails { md_types = type_env- , md_insts = insts+ , md_insts = mkInstEnv insts , md_fam_insts = fam_insts , md_rules = rules , md_anns = anns@@ -1164,8 +1164,8 @@ -} tcRoughTyCon :: Maybe IfaceTyCon -> RoughMatchTc-tcRoughTyCon (Just tc) = KnownTc (ifaceTyConName tc)-tcRoughTyCon Nothing = OtherTc+tcRoughTyCon (Just tc) = RM_KnownTc (ifaceTyConName tc)+tcRoughTyCon Nothing = RM_WildCard tcIfaceInst :: IfaceClsInst -> IfL ClsInst tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag@@ -1553,9 +1553,9 @@ tcIfaceExpr (IfaceTick tickish expr) = do expr' <- tcIfaceExpr expr -- If debug flag is not set: Ignore source notes- dbgLvl <- fmap debugLevel getDynFlags+ need_notes <- needSourceNotes <$> getDynFlags case tickish of- IfaceSource{} | dbgLvl == 0+ IfaceSource{} | not (need_notes) -> return expr' _otherwise -> do tickish' <- tcIfaceTickish tickish@@ -1618,6 +1618,7 @@ tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails tcIdDetails _ IfVanillaId = return VanillaId+tcIdDetails _ (IfStrictWorkerId dmds) = return $ StrictWorkerId dmds tcIdDetails ty IfDFunId = return (DFunId (isNewTyCon (classTyCon cls))) where@@ -1665,6 +1666,9 @@ lf_info <- tcLFInfo lf_info return (info `setLFInfo` lf_info) + tcPrag info (HsTagSig sig) = do+ return (info `setTagSig` sig)+ -- The next two are lazy, so they don't transitively suck stuff in tcPrag info (HsUnfold lb if_unf) = do { unf <- tcUnfolding toplvl name ty info if_unf@@ -1709,53 +1713,67 @@ return (LFUnknown fun_flag) tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding+-- See Note [Lazily checking Unfoldings] tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr) = do { uf_opts <- unfoldingOpts <$> getDynFlags- ; mb_expr <- tcPragExpr False toplvl name if_expr+ ; expr <- tcUnfoldingRhs False toplvl name if_expr ; let unf_src | stable = InlineStable | otherwise = InlineRhs- ; return $ case mb_expr of- Nothing -> NoUnfolding- Just expr -> mkFinalUnfolding uf_opts unf_src strict_sig expr- }+ ; return $ mkFinalUnfolding uf_opts unf_src strict_sig expr } where -- Strictness should occur before unfolding! strict_sig = dmdSigInfo info tcUnfolding toplvl name _ _ (IfCompulsory if_expr)- = do { mb_expr <- tcPragExpr True toplvl name if_expr- ; return (case mb_expr of- Nothing -> NoUnfolding- Just expr -> mkCompulsoryUnfolding' expr) }+ = do { expr <- tcUnfoldingRhs True toplvl name if_expr+ ; return $ mkCompulsoryUnfolding' expr } tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)- = do { mb_expr <- tcPragExpr False toplvl name if_expr- ; return (case mb_expr of- Nothing -> NoUnfolding- Just expr -> mkCoreUnfolding InlineStable True expr guidance )}+ = do { expr <- tcUnfoldingRhs False toplvl name if_expr+ ; return $ mkCoreUnfolding InlineStable True expr guidance } where guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } tcUnfolding _toplvl name dfun_ty _ (IfDFunUnfold bs ops) = bindIfaceBndrs bs $ \ bs' ->- do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops- ; return (case mb_ops1 of- Nothing -> noUnfolding- Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) }+ do { ops1 <- forkM doc $ mapM tcIfaceExpr ops+ ; return $ mkDFunUnfolding bs' (classDataCon cls) ops1 } where doc = text "Class ops for dfun" <+> ppr name (_, _, cls, _) = tcSplitDFunTy dfun_ty -{--For unfoldings we try to do the job lazily, so that we never type check+{- Note [Lazily checking Unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For unfoldings, we try to do the job lazily, so that we never typecheck an unfolding that isn't going to be looked at.++The main idea is that if M.hi has a declaration+ f :: Int -> Int+ f = \x. ...A.g... -- The unfolding for f++then we don't even want to /read/ A.hi unless f's unfolding is actually used; say,+if f is inlined. But we need to be careful. Even if we don't inline f, we might ask+hasNoBinding of it (Core Lint does this in GHC.Core.Lint.checkCanEtaExpand),+and hasNoBinding looks to see if f has a compulsory unfolding.+So the root Unfolding constructor must be visible: we want to be able to read the 'uf_src'+field which says whether it is a compulsory unfolding, without forcing the unfolding RHS+which is stored in 'uf_tmpl'. This matters for efficiency, but not only: if g's unfolding+mentions f, we must not look at the unfolding RHS for f, as this is precisely what we are+in the middle of checking (so looking at it would cause a loop).++Conclusion: `tcUnfolding` must return an `Unfolding` whose `uf_src` field is readable without+forcing the `uf_tmpl` field. In particular, all the functions used at the end of+`tcUnfolding` (such as `mkFinalUnfolding`, `mkCompulsoryUnfolding'`, `mkCoreUnfolding`) must be+lazy in `expr`.++Ticket #21139 -} -tcPragExpr :: Bool -- Is this unfolding compulsory?- -- See Note [Checking for representation polymorphism] in GHC.Core.Lint- -> TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr)-tcPragExpr is_compulsory toplvl name expr- = forkM_maybe doc $ do+tcUnfoldingRhs :: Bool -- ^ Is this unfolding compulsory?+ -- See Note [Checking for representation polymorphism] in GHC.Core.Lint+ -> TopLevelFlag -> Name -> IfaceExpr -> IfL CoreExpr+tcUnfoldingRhs is_compulsory toplvl name expr+ = forkM doc $ do core_expr' <- tcIfaceExpr expr -- Check for type consistency in the unfolding
compiler/GHC/Linker/Loader.hs view
@@ -29,8 +29,6 @@ , withExtendedLoadedEnv , extendLoadedEnv , deleteFromLoadedEnv- -- * Misc- , extendLoadedPkgs ) where @@ -66,6 +64,7 @@ import GHC.Types.Name.Env import GHC.Types.SrcLoc import GHC.Types.Unique.DSet+import GHC.Types.Unique.DFM import GHC.Utils.Outputable import GHC.Utils.Panic@@ -88,7 +87,6 @@ import qualified GHC.Data.ShortText as ST import qualified GHC.Data.Maybe as Maybes import GHC.Data.FastString-import GHC.Data.List.SetOps import GHC.Linker.MacOS import GHC.Linker.Dynamic@@ -98,9 +96,10 @@ import Control.Monad import qualified Data.Set as Set+import qualified Data.Map as M import Data.Char (isSpace) import Data.IORef-import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition, find)+import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition) import Data.Maybe import Control.Concurrent.MVar import qualified Control.Monad.Catch as MC@@ -115,14 +114,14 @@ #endif import GHC.Utils.Exception-import qualified Data.Map as M-import Data.Either (partitionEithers) import GHC.Unit.Module.Graph import GHC.Types.SourceFile import GHC.Utils.Misc import GHC.Iface.Load import GHC.Unit.Home+import Data.Either+import Control.Applicative uninitialised :: a uninitialised = panic "Loader not initialised"@@ -147,11 +146,8 @@ { closure_env = emptyNameEnv , itbl_env = emptyNameEnv , pkgs_loaded = init_pkgs- , bcos_loaded = []- , objs_loaded = []- , hs_objs_loaded = []- , non_hs_objs_loaded = []- , module_deps = M.empty+ , bcos_loaded = emptyModuleEnv+ , objs_loaded = emptyModuleEnv , temp_sos = [] } -- Packages that don't need loading, because the compiler@@ -159,12 +155,7 @@ -- -- The linker's symbol table is populated with RTS symbols using an -- explicit list. See rts/Linker.c for details.- where init_pkgs = [rtsUnitId]--extendLoadedPkgs :: Interp -> [UnitId] -> IO ()-extendLoadedPkgs interp pkgs =- modifyLoaderState_ interp $ \s ->- return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }+ where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] emptyUniqDSet) extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO () extendLoadedEnv interp new_bindings =@@ -183,21 +174,21 @@ -- | Load the module containing the given Name and get its associated 'HValue'. -- -- Throws a 'ProgramError' if loading fails or the name cannot be found.-loadName :: Interp -> HscEnv -> Maybe ModuleNameWithIsBoot -> Name -> IO ForeignHValue-loadName interp hsc_env mnwib name = do+loadName :: Interp -> HscEnv -> Name -> IO (ForeignHValue, [Linkable], PkgsLoaded)+loadName interp hsc_env name = do initLoaderState interp hsc_env modifyLoaderState interp $ \pls0 -> do- pls <- if not (isExternalName name)- then return pls0+ (pls, links, pkgs) <- if not (isExternalName name)+ then return (pls0, [], emptyUDFM) else do- (pls', ok) <- loadDependencies interp hsc_env pls0 (noSrcSpan, mnwib)- [nameModule name]+ (pls', ok, links, pkgs) <- loadDependencies interp hsc_env pls0 noSrcSpan+ [nameModule name] if failed ok then throwGhcExceptionIO (ProgramError "")- else return pls'+ else return (pls', links, pkgs) case lookupNameEnv (closure_env pls) name of- Just (_,aa) -> return (pls,aa)+ Just (_,aa) -> return (pls,(aa, links, pkgs)) Nothing -> assertPpr (isExternalName name) (ppr name) $ do let sym_to_find = nameToCLabel name "closure" m <- lookupClosure interp (unpackFS sym_to_find)@@ -205,14 +196,15 @@ Just hvref -> mkFinalizedHValue interp hvref Nothing -> linkFail "GHC.Linker.Loader.loadName" (unpackFS sym_to_find)- return (pls,r)+ return (pls,(r, links, pkgs)) loadDependencies :: Interp -> HscEnv -> LoaderState- -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> [Module]- -> IO (LoaderState, SuccessFlag)+ -> SrcSpan+ -> [Module]+ -> IO (LoaderState, SuccessFlag, [Linkable], PkgsLoaded) -- ^ returns the set of linkables required loadDependencies interp hsc_env pls span needed_mods = do -- initLoaderState (hsc_dflags hsc_env) dl let dflags = hsc_dflags hsc_env@@ -220,20 +212,23 @@ -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. -- So here we check the build tag: if we're building a non-standard way -- then we need to find & link object files built the "normal" way.- maybe_normal_osuf <- checkNonStdWay dflags interp (fst span)+ maybe_normal_osuf <- checkNonStdWay dflags interp span -- Find what packages and linkables are required- (lnks, all_lnks, pkgs) <- getLinkDeps hsc_env pls- maybe_normal_osuf (fst span) needed_mods-- let pls1 =- case snd span of- Just mn -> pls { module_deps = M.insertWith (++) mn all_lnks (module_deps pls) }- Nothing -> pls+ (lnks, all_lnks, pkgs, this_pkgs_needed)+ <- getLinkDeps hsc_env pls+ maybe_normal_osuf span needed_mods -- Link the packages and modules required- pls2 <- loadPackages' interp hsc_env pkgs pls1- loadModules interp hsc_env pls2 lnks+ pls1 <- loadPackages' interp hsc_env pkgs pls+ (pls2, succ) <- loadModuleLinkables interp hsc_env pls1 lnks+ let this_pkgs_loaded = udfmRestrictKeys all_pkgs_loaded $ getUniqDSet trans_pkgs_needed+ all_pkgs_loaded = pkgs_loaded pls2+ trans_pkgs_needed = unionManyUniqDSets (this_pkgs_needed : [ loaded_pkg_trans_deps pkg+ | pkg_id <- uniqDSetToList this_pkgs_needed+ , Just pkg <- [lookupUDFM all_pkgs_loaded pkg_id]+ ])+ return (pls2, succ, all_lnks, this_pkgs_loaded) -- | Temporarily extend the loaded env.@@ -266,9 +261,9 @@ ls <- readMVar (loader_state (interpLoader interp)) let docs = case ls of Nothing -> [ text "Loader not initialised"]- Just pls -> [ text "Pkgs:" <+> ppr (pkgs_loaded pls)- , text "Objs:" <+> ppr (objs_loaded pls)- , text "BCOs:" <+> ppr (bcos_loaded pls)+ Just pls -> [ text "Pkgs:" <+> ppr (map loaded_pkg_uid $ eltsUDFM $ pkgs_loaded pls)+ , text "Objs:" <+> ppr (moduleEnvElts $ objs_loaded pls)+ , text "BCOs:" <+> ppr (moduleEnvElts $ bcos_loaded pls) ] return $ withPprStyle defaultDumpStyle@@ -444,7 +439,7 @@ go [] [] = [] {- Note [preload packages]-+ ~~~~~~~~~~~~~~~~~~~~~~~ Why do we need to preload packages from the command line? This is an explanation copied from #2437: @@ -588,7 +583,7 @@ -- Raises an IO exception ('ProgramError') if it can't find a compiled -- version of the dependents to load. ---loadExpr :: Interp -> HscEnv -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> UnlinkedBCO -> IO ForeignHValue+loadExpr :: Interp -> HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue loadExpr interp hsc_env span root_ul_bco = do -- Initialise the linker (if it's not been done already) initLoaderState interp hsc_env@@ -596,7 +591,7 @@ -- Take lock for the actual work. modifyLoaderState interp $ \pls0 -> do -- Load the packages and modules required- (pls, ok) <- loadDependencies interp hsc_env pls0 span needed_mods+ (pls, ok, _, _) <- loadDependencies interp hsc_env pls0 span needed_mods if failed ok then throwGhcExceptionIO (ProgramError "") else do@@ -691,7 +686,9 @@ -> Maybe FilePath -- replace object suffixes? -> SrcSpan -- for error messages -> [Module] -- If you need these- -> IO ([Linkable], [Linkable], [UnitId]) -- ... then link these first+ -> IO ([Linkable], [Linkable], [UnitId], UniqDSet UnitId) -- ... then link these first+ -- The module and package dependencies for the needed modules are returned.+ -- See Note [Object File Dependencies] -- Fails with an IO exception if it can't find enough files getLinkDeps hsc_env pls replace_osuf span mods@@ -708,16 +705,16 @@ emptyUniqDSet emptyUniqDSet; else do (pkgs, mmods) <- unzip <$> mapM get_mod_info all_home_mods- return (catMaybes mmods, Set.toList (Set.unions (init_pkg_set : pkgs)))+ return (catMaybes mmods, unionManyUniqDSets (init_pkg_set : pkgs)) ; let -- 2. Exclude ones already linked -- Main reason: avoid findModule calls in get_linkable- (mods_needed, mods_got) = partitionEithers (map split_mods mods_s)- pkgs_needed = pkgs_s `minusList` pkgs_loaded pls+ (mods_needed, links_got) = partitionEithers (map split_mods mods_s)+ pkgs_needed = eltsUDFM $ getUniqDSet pkgs_s `minusUDFM` pkgs_loaded pls split_mods mod =- let is_linked = find ((== mod) . (linkableModule)) (objs_loaded pls ++ bcos_loaded pls)+ let is_linked = findModuleLinkable_maybe (objs_loaded pls) mod <|> findModuleLinkable_maybe (bcos_loaded pls) mod in case is_linked of Just linkable -> Right linkable Nothing -> Left mod@@ -728,7 +725,7 @@ ; let { osuf = objectSuf dflags } ; lnks_needed <- mapM (get_linkable osuf) mods_needed - ; return (lnks_needed, mods_got ++ lnks_needed, pkgs_needed) }+ ; return (lnks_needed, links_got ++ lnks_needed, pkgs_needed, pkgs_s) } where dflags = hsc_dflags hsc_env mod_graph = hsc_mod_graph hsc_env@@ -741,7 +738,7 @@ -- It is also a matter of correctness to use the module graph so that dependencies between home units -- is resolved correctly.- make_deps_loop :: (Set.Set UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (Set.Set UnitId, Set.Set NodeKey)+ make_deps_loop :: (UniqDSet UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set.Set NodeKey) make_deps_loop found [] = found make_deps_loop found@(found_units, found_mods) (nk:nexts) | NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts@@ -755,10 +752,10 @@ in make_deps_loop (found_units, deps `Set.union` found_mods) (todo_boot_mods ++ nexts) Nothing -> let (ModNodeKeyWithUid _ uid) = nk- in make_deps_loop (uid `Set.insert` found_units, found_mods) nexts+ in make_deps_loop (addOneToUniqDSet found_units uid, found_mods) nexts mkNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m)- (init_pkg_set, all_deps) = make_deps_loop (Set.empty, Set.empty) $ map mkNk (filterOut isInteractiveModule mods)+ (init_pkg_set, all_deps) = make_deps_loop (emptyUniqDSet, Set.empty) $ map mkNk (filterOut isInteractiveModule mods) all_home_mods = [with_uid | NodeKey_Module with_uid <- Set.toList all_deps] @@ -770,7 +767,7 @@ HsBootFile -> link_boot_mod_error (mi_module iface) _ -> return $ Just (mi_module iface) - in (dep_direct_pkgs (mi_deps iface),) <$> mmod+ in (mkUniqDSet $ Set.toList $ dep_direct_pkgs (mi_deps iface),) <$> mmod Nothing -> let err = text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid in throwGhcExceptionIO (ProgramError (showSDoc dflags err))@@ -786,9 +783,9 @@ follow_deps :: [Module] -- modules to follow -> UniqDSet Module -- accum. module dependencies -> UniqDSet UnitId -- accum. package dependencies- -> IO ([Module], [UnitId]) -- result+ -> IO ([Module], UniqDSet UnitId) -- result follow_deps [] acc_mods acc_pkgs- = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs)+ = return (uniqDSetToList acc_mods, acc_pkgs) follow_deps (mod:mods) acc_mods acc_pkgs = do mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $@@ -892,14 +889,13 @@ adjust_ul _ l@(BCOs {}) = return l - {- ********************************************************************** Loading a Decls statement ********************************************************************* -} -loadDecls :: Interp -> HscEnv -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> CompiledByteCode -> IO [(Name, ForeignHValue)]+loadDecls :: Interp -> HscEnv -> SrcSpan -> CompiledByteCode -> IO ([(Name, ForeignHValue)], [Linkable], PkgsLoaded) loadDecls interp hsc_env span cbc@CompiledByteCode{..} = do -- Initialise the linker (if it's not been done already) initLoaderState interp hsc_env@@ -907,7 +903,7 @@ -- Take lock for the actual work. modifyLoaderState interp $ \pls0 -> do -- Link the packages and modules required- (pls, ok) <- loadDependencies interp hsc_env pls0 span needed_mods+ (pls, ok, links_needed, units_needed) <- loadDependencies interp hsc_env pls0 span needed_mods if failed ok then throwGhcExceptionIO (ProgramError "") else do@@ -921,7 +917,7 @@ nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs , itbl_env = ie }- return (pls2, nms_fhvs)+ return (pls2, (nms_fhvs, links_needed, units_needed)) where free_names = uniqDSetToList $ foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos@@ -942,11 +938,11 @@ ********************************************************************* -} -loadModule :: Interp -> HscEnv -> Maybe ModuleNameWithIsBoot -> Module -> IO ()-loadModule interp hsc_env mnwib mod = do+loadModule :: Interp -> HscEnv -> Module -> IO ()+loadModule interp hsc_env mod = do initLoaderState interp hsc_env modifyLoaderState_ interp $ \pls -> do- (pls', ok) <- loadDependencies interp hsc_env pls (noSrcSpan, mnwib) [mod]+ (pls', ok, _, _) <- loadDependencies interp hsc_env pls noSrcSpan [mod] if failed ok then throwGhcExceptionIO (ProgramError "could not load module") else return pls'@@ -959,8 +955,8 @@ ********************************************************************* -} -loadModules :: Interp -> HscEnv -> LoaderState -> [Linkable] -> IO (LoaderState, SuccessFlag)-loadModules interp hsc_env pls linkables+loadModuleLinkables :: Interp -> HscEnv -> LoaderState -> [Linkable] -> IO (LoaderState, SuccessFlag)+loadModuleLinkables interp hsc_env pls linkables = mask_ $ do -- don't want to be interrupted by ^C in here let (objs, bcos) = partition isObjectLinkable@@ -989,14 +985,10 @@ li {linkableUnlinked=li_uls_bco}] _ -> [li] -findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable-findModuleLinkable_maybe lis mod- = case [LM time nm us | LM time nm us <- lis, nm == mod] of- [] -> Nothing- [li] -> Just li- _ -> pprPanic "findModuleLinkable" (ppr mod)+findModuleLinkable_maybe :: LinkableSet -> Module -> Maybe Linkable+findModuleLinkable_maybe = lookupModuleEnv -linkableInSet :: Linkable -> [Linkable] -> Bool+linkableInSet :: Linkable -> LinkableSet -> Bool linkableInSet l objs_loaded = case findModuleLinkable_maybe objs_loaded (linkableModule l) of Nothing -> False@@ -1100,7 +1092,7 @@ -- link all "loaded packages" so symbols in those can be resolved -- Note: We are loading packages with local scope, so to see the -- symbols in this link we must link all loaded packages again.- linkDynLib logger tmpfs dflags2 unit_env objs pkgs_loaded+ linkDynLib logger tmpfs dflags2 unit_env objs (loaded_pkg_uid <$> eltsUDFM pkgs_loaded) -- if we got this far, extend the lifetime of the library file changeTempFilesLifetime tmpfs TFL_GhcSession [soFile]@@ -1111,9 +1103,9 @@ where msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed" -rmDupLinkables :: [Linkable] -- Already loaded+rmDupLinkables :: LinkableSet -- Already loaded -> [Linkable] -- New linkables- -> ([Linkable], -- New loaded set (including new ones)+ -> (LinkableSet, -- New loaded set (including new ones) [Linkable]) -- New linkables (excluding dups) rmDupLinkables already ls = go already [] ls@@ -1121,7 +1113,7 @@ go already extras [] = (already, extras) go already extras (l:ls) | linkableInSet l already = go already extras ls- | otherwise = go (l:already) (l:extras) ls+ | otherwise = go (extendModuleEnv already (linkableModule l) l) (l:extras) ls {- ********************************************************************** @@ -1232,9 +1224,9 @@ let logger = hsc_logger hsc_env debugTraceMsg logger 3 $- text "unload: retaining objs" <+> ppr (objs_loaded new_pls)+ text "unload: retaining objs" <+> ppr (moduleEnvElts $ objs_loaded new_pls) debugTraceMsg logger 3 $- text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)+ text "unload: retaining bcos" <+> ppr (moduleEnvElts $ bcos_loaded new_pls) return () unload_wkr@@ -1250,32 +1242,32 @@ -- we're unloading some code. -fghci-leak-check with the tests in -- testsuite/ghci can detect space leaks here. - let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables+ let (objs_to_keep', bcos_to_keep') = partition isObjectLinkable keep_linkables+ objs_to_keep = mkLinkableSet objs_to_keep'+ bcos_to_keep = mkLinkableSet bcos_to_keep' discard keep l = not (linkableInSet l keep) (objs_to_unload, remaining_objs_loaded) =- partition (discard objs_to_keep) objs_loaded+ partitionModuleEnv (discard objs_to_keep) objs_loaded (bcos_to_unload, remaining_bcos_loaded) =- partition (discard bcos_to_keep) bcos_loaded+ partitionModuleEnv (discard bcos_to_keep) bcos_loaded - mapM_ unloadObjs objs_to_unload- mapM_ unloadObjs bcos_to_unload+ linkables_to_unload = moduleEnvElts objs_to_unload ++ moduleEnvElts bcos_to_unload + mapM_ unloadObjs linkables_to_unload+ -- If we unloaded any object files at all, we need to purge the cache -- of lookupSymbol results.- when (not (null (objs_to_unload ++- filter (not . null . linkableObjs) bcos_to_unload))) $+ when (not (null (filter (not . null . linkableObjs) linkables_to_unload))) $ purgeLookupSymbolCache interp - let !bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded-- -- Note that we want to remove all *local*+ let -- Note that we want to remove all *local* -- (i.e. non-isExternal) names too (these are the -- temporary bindings from the command line). keep_name :: (Name, a) -> Bool keep_name (n,_) = isExternalName n &&- nameModule n `elemModuleSet` bcos_retained+ nameModule n `elemModuleEnv` remaining_bcos_loaded itbl_env' = filterNameEnv keep_name itbl_env closure_env' = filterNameEnv keep_name closure_env@@ -1350,25 +1342,29 @@ loadPackages' :: Interp -> HscEnv -> [UnitId] -> LoaderState -> IO LoaderState loadPackages' interp hsc_env new_pks pls = do- (pkgs', hs_objs, non_hs_objs) <- link (pkgs_loaded pls) new_pks+ pkgs' <- link (pkgs_loaded pls) new_pks return $! pls { pkgs_loaded = pkgs'- , hs_objs_loaded = hs_objs ++ hs_objs_loaded pls- , non_hs_objs_loaded = non_hs_objs ++ non_hs_objs_loaded pls }+ } where- link :: [UnitId] -> [UnitId] -> IO ([UnitId], [LibrarySpec], [LibrarySpec])+ link :: PkgsLoaded -> [UnitId] -> IO PkgsLoaded link pkgs new_pkgs =- foldM link_one (pkgs, [],[]) new_pkgs+ foldM link_one pkgs new_pkgs - link_one (pkgs, acc_hs, acc_non_hs) new_pkg- | new_pkg `elem` pkgs -- Already linked- = return (pkgs, acc_hs, acc_non_hs)+ link_one pkgs new_pkg+ | new_pkg `elemUDFM` pkgs -- Already linked+ = return pkgs | Just pkg_cfg <- lookupUnitId (hsc_units hsc_env) new_pkg- = do { -- Link dependents first- (pkgs', hs_cls', extra_cls') <- link pkgs (unitDepends pkg_cfg)+ = do { let deps = unitDepends pkg_cfg+ -- Link dependents first+ ; pkgs' <- link pkgs deps -- Now link the package itself ; (hs_cls, extra_cls) <- loadPackage interp hsc_env pkg_cfg- ; return (new_pkg : pkgs', acc_hs ++ hs_cls ++ hs_cls', acc_non_hs ++ extra_cls ++ extra_cls') }+ ; let trans_deps = unionManyUniqDSets [ addOneToUniqDSet (loaded_pkg_trans_deps loaded_pkg_info) dep_pkg+ | dep_pkg <- deps+ , Just loaded_pkg_info <- pure (lookupUDFM pkgs' dep_pkg)+ ]+ ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls trans_deps)) } | otherwise = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg)))
compiler/GHC/Llvm/Ppr.hs view
@@ -219,7 +219,8 @@ BranchIf cond ifT ifF -> ind $ ppBranchIf opts cond ifT ifF Comment comments -> ind $ ppLlvmComments comments MkLabel label -> ppLlvmBlockLabel label- Store value ptr -> ind $ ppStore opts value ptr+ Store value ptr align+ -> ind $ ppStore opts value ptr align Switch scrut def tgs -> ind $ ppSwitch opts scrut def tgs Return result -> ind $ ppReturn opts result Expr expr -> ind $ ppLlvmExpression opts expr@@ -242,7 +243,7 @@ ExtractV struct idx -> ppExtractV opts struct idx Insert vec elt idx -> ppInsert opts vec elt idx GetElemPtr inb ptr indexes -> ppGetElementPtr opts inb ptr indexes- Load ptr -> ppLoad opts ptr+ Load ptr align -> ppLoad opts ptr align ALoad ord st ptr -> ppALoad opts ord st ptr Malloc tp amount -> ppMalloc opts tp amount AtomicRMW aop tgt src ordering -> ppAtomicRMW opts aop tgt src ordering@@ -365,20 +366,16 @@ text "cmpxchg" <+> ppVar opts addr <> comma <+> ppVar opts old <> comma <+> ppVar opts new <+> ppSyncOrdering s_ord <+> ppSyncOrdering f_ord --- XXX: On x86, vector types need to be 16-byte aligned for aligned access, but--- we have no way of guaranteeing that this is true with GHC (we would need to--- modify the layout of the stack and closures, change the storage manager,--- etc.). So, we blindly tell LLVM that *any* vector store or load could be--- unaligned. In the future we may be able to guarantee that certain vector--- access patterns are aligned, in which case we will need a more granular way--- of specifying alignment. -ppLoad :: LlvmCgConfig -> LlvmVar -> SDoc-ppLoad opts var = text "load" <+> ppr derefType <> comma <+> ppVar opts var <> align+ppLoad :: LlvmCgConfig -> LlvmVar -> LMAlign -> SDoc+ppLoad opts var alignment =+ text "load" <+> ppr derefType <> comma <+> ppVar opts var <> align where derefType = pLower $ getVarType var- align | isVector . pLower . getVarType $ var = text ", align 1"- | otherwise = empty+ align =+ case alignment of+ Just n -> text ", align" <+> ppr n+ Nothing -> empty ppALoad :: LlvmCgConfig -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc ppALoad opts ord st var =@@ -390,14 +387,14 @@ in text "load atomic" <+> ppr derefType <> comma <+> ppVar opts var <> sThreaded <+> ppSyncOrdering ord <> align -ppStore :: LlvmCgConfig -> LlvmVar -> LlvmVar -> SDoc-ppStore opts val dst- | isVecPtrVar dst = text "store" <+> ppVar opts val <> comma <+> ppVar opts dst <>- comma <+> text "align 1"- | otherwise = text "store" <+> ppVar opts val <> comma <+> ppVar opts dst+ppStore :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LMAlign -> SDoc+ppStore opts val dst alignment =+ text "store" <+> ppVar opts val <> comma <+> ppVar opts dst <> align where- isVecPtrVar :: LlvmVar -> Bool- isVecPtrVar = isVector . pLower . getVarType+ align =+ case alignment of+ Just n -> text ", align" <+> ppr n+ Nothing -> empty ppCast :: LlvmCgConfig -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
compiler/GHC/Llvm/Syntax.hs view
@@ -150,7 +150,7 @@ * value: Variable/Constant to store. * ptr: Location to store the value in -}- | Store LlvmVar LlvmVar+ | Store LlvmVar LlvmVar LMAlign {- | Multiway branch@@ -252,7 +252,7 @@ {- | Load the value at location ptr -}- | Load LlvmVar+ | Load LlvmVar LMAlign {- | Atomic load of the value at location ptr
compiler/GHC/Rename/Bind.hs view
@@ -42,7 +42,7 @@ import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Fixity-import GHC.Rename.Utils ( HsDocContext(..), mapFvRn+import GHC.Rename.Utils ( mapFvRn , checkDupRdrNames, checkDupRdrNamesN , warnUnusedLocalBinds , warnForallIdentifier@@ -244,9 +244,9 @@ return (IPBinds noExtField ip_binds', plusFVs fvs_s) rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars)-rnIPBind (IPBind _ ~(Left n) expr) = do+rnIPBind (IPBind _ n expr) = do (expr',fvExpr) <- rnLExpr expr- return (IPBind noAnn (Left n) expr', fvExpr)+ return (IPBind noExtField n expr', fvExpr) {- ************************************************************************
compiler/GHC/Rename/Env.hs view
@@ -495,7 +495,8 @@ , isUnboundName con -- Avoid error cascade = return (mkUnboundNameRdr rdr_name) | Just con <- mb_con- = do { flds <- lookupConstructorFields con+ = lookupExactOrOrig rdr_name id $ -- See Note [Record field names and Template Haskell]+ do { flds <- lookupConstructorFields con ; env <- getGlobalRdrEnv ; let lbl = occNameFS (rdrNameOcc rdr_name) mb_field = do fl <- find ((== lbl) . flLabel) flds@@ -511,12 +512,13 @@ ; case mb_field of Just (fl, gre) -> do { addUsedGRE True gre ; return (flSelector fl) }- Nothing -> lookupGlobalOccRn' WantBoth rdr_name }- -- See Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]- | otherwise- -- This use of Global is right as we are looking up a selector which- -- can only be defined at the top level.+ Nothing -> do { addErr (badFieldConErr con lbl)+ ; return (mkUnboundNameRdr rdr_name) } }++ | otherwise -- Can't use the data constructor to disambiguate = lookupGlobalOccRn' WantBoth rdr_name+ -- This use of Global is right as we are looking up a selector,+ -- which can only be defined at the top level. -- | Look up an occurrence of a field in a record update, returning the selector -- name.@@ -632,25 +634,8 @@ qualifier to be omitted, because we do not have a data constructor from which to determine it. --Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Whenever we fail to find the field or it is not in scope, mb_field-will be False, and we fall back on looking it up normally using-lookupGlobalOccRn. We don't report an error immediately because the-actual problem might be located elsewhere. For example (#9975):-- data Test = Test { x :: Int }- pattern Test wat = Test { x = wat }--Here there are multiple declarations of Test (as a data constructor-and as a pattern synonym), which will be reported as an error. We-shouldn't also report an error about the occurrence of `x` in the-pattern synonym RHS. However, if the pattern synonym gets added to-the environment first, we will try and fail to find `x` amongst the-(nonexistent) fields of the pattern synonym.--Alternatively, the scope check can fail due to Template Haskell.+Note [Record field names and Template Haskell]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (#12130): module Foo where@@ -669,7 +654,6 @@ -} - -- | Used in export lists to lookup the children. lookupSubBndrOcc_helper :: Bool -> Bool -> Name -> RdrName -> RnM ChildLookupResult@@ -834,7 +818,7 @@ -> RdrName -> RnM (Either NotInScopeError Name) -- Find all the things the rdr-name maps to--- and pick the one with the right parent namep+-- and pick the one with the right parent name lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do res <- lookupExactOrOrig rdr_name (FoundChild NoParent . NormalGreName) $@@ -1430,7 +1414,7 @@ {- Note [ Unbound vs Ambiguous Names ]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ lookupGreRn_maybe deals with failures in two different ways. If a name is unbound then we return a `Nothing` but if the name is ambiguous then we raise an error and return a dummy name.
compiler/GHC/Rename/Expr.hs view
@@ -38,7 +38,7 @@ import GHC.Unit.Module ( getModule, isInteractiveModule ) import GHC.Rename.Env import GHC.Rename.Fixity-import GHC.Rename.Utils ( HsDocContext(..), bindLocalNamesFV, checkDupNames+import GHC.Rename.Utils ( bindLocalNamesFV, checkDupNames , bindLocalNames , mapMaybeFvRn, mapFvRn , warnUnusedLocalBinds, typeAppErr@@ -1720,7 +1720,7 @@ ************************************************************************ Note [ApplicativeDo]-+~~~~~~~~~~~~~~~~~~~~ = Example = For a sequence of statements@@ -1826,6 +1826,12 @@ <*> ... <*> argexpr(arg_n) +== Special cases ==++If a do-expression contains only "return E" or "return $ E" plus+zero or more let-statements, we replace the "return" with "pure".+See Section 3.6 of the paper.+ = Relevant modules in the rest of the compiler = ApplicativeDo touches a few phases in the compiler:@@ -1873,7 +1879,17 @@ -> RnM ([ExprLStmt GhcRn], FreeVars) rearrangeForApplicativeDo _ [] = return ([], emptyNameSet)-rearrangeForApplicativeDo _ [(one,_)] = return ([one], emptyNameSet)+-- If the do-block contains a single @return@ statement, change it to+-- @pure@ if ApplicativeDo is turned on. See Note [ApplicativeDo].+rearrangeForApplicativeDo ctxt [(one,_)] = do+ (return_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) returnMName+ (pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName+ let pure_expr = nl_HsVar pure_name+ let monad_names = MonadNames { return_name = return_name+ , pure_name = pure_name }+ return $ case needJoin monad_names [one] (Just pure_expr) of+ (False, one') -> (one', emptyNameSet)+ (True, _) -> ([one], emptyNameSet) rearrangeForApplicativeDo ctxt stmts0 = do optimal_ado <- goptM Opt_OptimalApplicativeDo let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts@@ -2007,9 +2023,12 @@ -- In the spec, but we do it here rather than in the desugarer, -- because we need the typechecker to typecheck the <$> form rather than -- the bind form, which would give rise to a Monad constraint.+--+-- If we have a single let, and the last statement is @return E@ or @return $ E@,+-- change the @return@ to @pure@. stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt xbs pat rhs), _)) tail _tail_fvs- | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail+ | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail Nothing -- See Note [ApplicativeDo and strict patterns] = mkApplicativeStmt ctxt [ApplicativeArgOne { xarg_app_arg_one = xbsrn_failOp xbs@@ -2020,7 +2039,7 @@ False tail' stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_)) tail _tail_fvs- | (False,tail') <- needJoin monad_names tail+ | (False,tail') <- needJoin monad_names tail Nothing = mkApplicativeStmt ctxt [ApplicativeArgOne { xarg_app_arg_one = Nothing@@ -2028,6 +2047,12 @@ , arg_expr = rhs , is_body_stmt = True }] False tail'+stmtTreeToStmts monad_names ctxt (StmtTreeOne (let_stmt@(L _ LetStmt{}),_))+ tail _tail_fvs = do+ (pure_expr, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) pureAName+ return $ case needJoin monad_names tail (Just pure_expr) of+ (False, tail') -> (let_stmt : tail', emptyNameSet)+ (True, _) -> (let_stmt : tail, emptyNameSet) stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs = return (s : tail, emptyNameSet)@@ -2046,7 +2071,7 @@ -- See Note [ApplicativeDo and refutable patterns] if any (hasRefutablePattern dflags) stmts' then (True, tail)- else needJoin monad_names tail+ else needJoin monad_names tail Nothing (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail' return (stmts, unionNameSets (fvs:fvss))@@ -2304,25 +2329,47 @@ -- | Given the statements following an ApplicativeStmt, determine whether -- we need a @join@ or not, and remove the @return@ if necessary.+--+-- We don't need @join@ if there's a single @LastStmt@ in the form of+-- @return E@, @return $ E@, @pure E@ or @pure $ E@. needJoin :: MonadNames -> [ExprLStmt GhcRn]+ -- If this is @Just pure@, replace return by pure+ -- If this is @Nothing@, strip the return/pure+ -> Maybe (HsExpr GhcRn) -> (Bool, [ExprLStmt GhcRn])-needJoin _monad_names [] = (False, []) -- we're in an ApplicativeArg-needJoin monad_names [L loc (LastStmt _ e _ t)]- | Just (arg, wasDollar) <- isReturnApp monad_names e =- (False, [L loc (LastStmt noExtField arg (Just wasDollar) t)])-needJoin _monad_names stmts = (True, stmts)+needJoin _monad_names [] _mb_pure = (False, []) -- we're in an ApplicativeArg+needJoin monad_names [L loc (LastStmt _ e _ t)] mb_pure+ | Just (arg, noret) <- isReturnApp monad_names e mb_pure =+ (False, [L loc (LastStmt noExtField arg noret t)])+needJoin _monad_names stmts _mb_pure = (True, stmts) --- | @(Just e, False)@, if the expression is @return e@--- @(Just e, True)@ if the expression is @return $ e@,+-- | @(Just e, Just False)@, if the expression is @return/pure e@,+-- and the third argument is Nothing,+-- @(Just e, Just True)@ if the expression is @return/pure $ e@,+-- and the third argument is Nothing,+-- @(Just (pure e), Nothing)@ if the expression is @return/pure e@,+-- and the third argument is @Just pure_expr@,+-- @(Just (pure $ e), Nothing)@ if the expression is @return/pure $ e@,+-- and the third argument is @Just pure_expr@, -- otherwise @Nothing@. isReturnApp :: MonadNames -> LHsExpr GhcRn- -> Maybe (LHsExpr GhcRn, Bool)-isReturnApp monad_names (L _ (HsPar _ _ expr _)) = isReturnApp monad_names expr-isReturnApp monad_names (L _ e) = case e of- OpApp _ l op r | is_return l, is_dollar op -> Just (r, True)- HsApp _ f arg | is_return f -> Just (arg, False)+ -- If this is @Just pure@, replace return by pure+ -- If this is @Nothing@, strip the return/pure+ -> Maybe (HsExpr GhcRn)+ -> Maybe (LHsExpr GhcRn, Maybe Bool)+isReturnApp monad_names (L _ (HsPar _ _ expr _)) mb_pure =+ isReturnApp monad_names expr mb_pure+isReturnApp monad_names (L loc e) mb_pure = case e of+ OpApp x l op r+ | Just pure_expr <- mb_pure, is_return l, is_dollar op ->+ Just (L loc (OpApp x (to_pure l pure_expr) op r), Nothing)+ | is_return l, is_dollar op -> Just (r, Just True)+ HsApp x f arg+ | Just pure_expr <- mb_pure, is_return f ->+ Just (L loc (HsApp x (to_pure f pure_expr) arg), Nothing)+ | is_return f -> Just (arg, Just False) _otherwise -> Nothing where is_var f (L _ (HsPar _ _ e _)) = is_var f e@@ -2333,6 +2380,7 @@ is_return = is_var (\n -> n == return_name monad_names || n == pure_name monad_names)+ to_pure (L loc _) pure_expr = L loc pure_expr is_dollar = is_var (`hasKey` dollarIdKey) {-
compiler/GHC/Rename/HsType.hs view
@@ -48,15 +48,15 @@ import GHC.Driver.Session import GHC.Hs import GHC.Rename.Env-import GHC.Rename.Utils ( HsDocContext(..), inHsDocContext, withHsDocContext- , mapFvRn, pprHsDocContext, bindLocalNamesFV+import GHC.Rename.Utils ( mapFvRn, bindLocalNamesFV , typeAppErr, newLocalBndrRn, checkDupRdrNamesN , checkShadowedRdrNames, warnForallIdentifier ) import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn , lookupTyFixityRn ) import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) ) import GHC.Tc.Errors.Types-import GHC.Tc.Errors.Ppr ( pprScopeError )+import GHC.Tc.Errors.Ppr ( pprScopeError+ , inHsDocContext, withHsDocContext, pprHsDocContext ) import GHC.Tc.Utils.Monad import GHC.Types.Name.Reader import GHC.Builtin.Names@@ -291,10 +291,11 @@ -- Check that extra-constraints are allowed at all, and -- if so that it's an anonymous wildcard checkExtraConstraintWildCard env hs_ctxt- = checkWildCard env mb_bad+ = checkWildCard env Nothing mb_bad where mb_bad | not (extraConstraintWildCardsAllowed env)- = Just base_msg+ = Just $ ExtraConstraintWildcardNotAllowed+ SoleExtraConstraintWildcardNotAllowed -- Currently, we do not allow wildcards in their full glory in -- standalone deriving declarations. We only allow a single -- extra-constraints wildcard à la:@@ -306,18 +307,11 @@ -- deriving instance (Eq a, _) => Eq (Foo a) | DerivDeclCtx {} <- rtke_ctxt env , not (null hs_ctxt)- = Just deriv_decl_msg+ = Just $ ExtraConstraintWildcardNotAllowed+ SoleExtraConstraintWildcardAllowed | otherwise = Nothing - base_msg = text "Extra-constraint wildcard" <+> quotes pprAnonWildCard- <+> text "not allowed"-- deriv_decl_msg- = hang base_msg- 2 (vcat [ text "except as the sole constraint"- , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ])- extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool extraConstraintWildCardsAllowed env = case rtke_ctxt env of@@ -840,46 +834,39 @@ ; return (l_op', unitFV op') } ---------------notAllowed :: SDoc -> SDoc-notAllowed doc- = text "Wildcard" <+> quotes doc <+> text "not allowed"--checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM ()-checkWildCard env (Just doc)- = addErr $ TcRnUnknownMessage $ mkPlainError noHints $- vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))]-checkWildCard _ Nothing+checkWildCard :: RnTyKiEnv+ -> Maybe Name -- ^ name of the wildcard,+ -- or 'Nothing' for an anonymous wildcard+ -> Maybe BadAnonWildcardContext+ -> RnM ()+checkWildCard env mb_name (Just bad)+ = addErr $ TcRnIllegalWildcardInType mb_name bad (Just $ rtke_ctxt env)+checkWildCard _ _ Nothing = return () checkAnonWildCard :: RnTyKiEnv -> RnM () -- Report an error if an anonymous wildcard is illegal here checkAnonWildCard env- = checkWildCard env mb_bad+ = checkWildCard env Nothing mb_bad where- mb_bad :: Maybe SDoc+ mb_bad :: Maybe BadAnonWildcardContext mb_bad | not (wildCardsAllowed env)- = Just (notAllowed pprAnonWildCard)+ = Just WildcardsNotAllowedAtAll | otherwise = case rtke_what env of RnTypeBody -> Nothing- RnTopConstraint -> Just constraint_msg- RnConstraint -> Just constraint_msg-- constraint_msg = hang- (notAllowed pprAnonWildCard <+> text "in a constraint")- 2 hint_msg- hint_msg = vcat [ text "except as the last top-level constraint of a type signature"- , nest 2 (text "e.g f :: (Eq a, _) => blah") ]+ RnTopConstraint -> Just WildcardNotLastInConstraint+ RnConstraint -> Just WildcardNotLastInConstraint checkNamedWildCard :: RnTyKiEnv -> Name -> RnM () -- Report an error if a named wildcard is illegal here checkNamedWildCard env name- = checkWildCard env mb_bad+ = checkWildCard env (Just name) mb_bad where mb_bad | not (name `elemNameSet` rtke_nwcs env) = Nothing -- Not a wildcard | not (wildCardsAllowed env)- = Just (notAllowed (ppr name))+ = Just WildcardsNotAllowedAtAll | otherwise = case rtke_what env of RnTypeBody -> Nothing -- Allowed@@ -887,8 +874,7 @@ -- f :: (Eq _a) => _a -> Int -- g :: (_a, _b) => T _a _b -> Int -- The named tyvars get filled in from elsewhere- RnConstraint -> Just constraint_msg- constraint_msg = notAllowed (ppr name) <+> text "in a constraint"+ RnConstraint -> Just WildcardNotLastInConstraint wildCardsAllowed :: RnTyKiEnv -> Bool -- ^ In what contexts are wildcards permitted@@ -961,8 +947,8 @@ -> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars)) -- The Bool is True <=> all kind variables used in the -- kind signature are bound on the left. Reason:- -- the last clause of Note [CUSKs: Complete user-supplied- -- kind signatures] in GHC.Hs.Decls+ -- the last clause of Note [CUSKs: complete user-supplied kind signatures]+ -- in GHC.Hs.Decls -> RnM (b, FreeVars) -- See Note [bindHsQTyVars examples]
compiler/GHC/Rename/Module.hs view
@@ -28,15 +28,16 @@ import GHC.Rename.HsType import GHC.Rename.Bind import GHC.Rename.Env-import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, bindLocalNames+import GHC.Rename.Utils ( mapFvRn, bindLocalNames , checkDupRdrNamesN, bindLocalNamesFV , checkShadowedRdrNames, warnUnusedTypePatterns , newLocalBndrsRn- , withHsDocContext, noNestedForallsContextsErr+ , noNestedForallsContextsErr , addNoNestedForallsContextsErr, checkInferredVars, warnForallIdentifier ) import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) ) import GHC.Rename.Names import GHC.Tc.Errors.Types+import GHC.Tc.Errors.Ppr (withHsDocContext) import GHC.Tc.Gen.Annotation ( annCtxt ) import GHC.Tc.Utils.Monad
compiler/GHC/Rename/Names.hs view
@@ -50,8 +50,7 @@ import GHC.Parser.PostProcess ( setRdrNameSpace ) import GHC.Core.Type import GHC.Core.PatSyn-import GHC.Core.TyCo.Ppr-import GHC.Core.TyCon ( TyCon, tyConName, tyConKind )+import GHC.Core.TyCon ( TyCon, tyConName ) import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.Outputable as Outputable@@ -690,7 +689,8 @@ -- see Note [Top-level Names in Template Haskell decl quotes] extendGlobalRdrEnvRn avails new_fixities- = do { (gbl_env, lcl_env) <- getEnvs+ = checkNoErrs $ -- See Note [Fail fast on duplicate definitions]+ do { (gbl_env, lcl_env) <- getEnvs ; stage <- getStage ; isGHCi <- getIsGHCi ; let rdr_env = tcg_rdr_env gbl_env@@ -767,7 +767,19 @@ (False, True) -> isNoFieldSelectorGRE gre' (False, False) -> False -{-+{- Note [Fail fast on duplicate definitions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If there are duplicate bindings for the same thing, we want to fail+fast. Having two bindings for the same thing can cause follow-on errors.+Example (test T9975a):+ data Test = Test { x :: Int }+ pattern Test wat = Test { x = wat }+This defines 'Test' twice. The second defn has no field-names; and then+we get an error from Test { x=wat }, saying "Test has no field 'x'".++Easiest thing is to bale out fast on duplicate definitions, which+we do via `checkNoErrs` on `extendGlobalRdrEnvRn`.+ Note [Reporting duplicate local declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In general, a single module may not define the same OccName multiple times. This@@ -1593,95 +1605,76 @@ -- inferred type of the function warnMissingSignatures :: TcGblEnv -> RnM () warnMissingSignatures gbl_env- = do { let exports = availsToNameSet (tcg_exports gbl_env)+ = do { warn_binds <- woptM Opt_WarnMissingSignatures+ ; warn_pat_syns <- woptM Opt_WarnMissingPatternSynonymSignatures+ ; let exports = availsToNameSet (tcg_exports gbl_env) sig_ns = tcg_sigs gbl_env -- We use sig_ns to exclude top-level bindings that are generated by GHC binds = collectHsBindsBinders CollNoDictBinders $ tcg_binds gbl_env pat_syns = tcg_patsyns gbl_env - -- Warn about missing signatures- -- Do this only when we have a type to offer- ; warn_binds <- woptM Opt_WarnMissingSignatures- ; warn_exported_binds <- woptM Opt_WarnMissingExportedSignatures- ; warn_pat_syns <- woptM Opt_WarnMissingPatternSynonymSignatures- ; warn_exported_pat_syns <- woptM Opt_WarnMissingExportedPatternSynonymSignatures-- -- See Note [Missing signatures]- ; let add_sig_warns- = when (warn_pat_syns || warn_exported_pat_syns)- (mapM_ add_pat_syn_warn pat_syns) >>- when (warn_binds || warn_exported_binds)- (mapM_ add_bind_warn binds)-- add_pat_syn_warn p- = when export_check $- add_warn name flag $- hang (text "Pattern synonym with no type signature:")- 2 (text "pattern" <+> pprPrefixName name <+> dcolon <+> pp_ty)- where- name = patSynName p- pp_ty = pprPatSynType p- export_check = warn_pat_syns || name `elemNameSet` exports- flag | warn_pat_syns- = Opt_WarnMissingPatternSynonymSignatures- | otherwise- = Opt_WarnMissingExportedPatternSynonymSignatures-- add_bind_warn :: Id -> IOEnv (Env TcGblEnv TcLclEnv) ()- add_bind_warn id- = do { env <- tcInitTidyEnv -- Why not use emptyTidyEnv?- ; let (_, ty) = tidyOpenType env (idType id)- ty_msg = pprSigmaType ty+ not_ghc_generated :: Name -> Bool+ not_ghc_generated name = name `elemNameSet` sig_ns - ; when export_check $- add_warn name flag $- hang (text "Top-level binding with no type signature:")- 2 (pprPrefixName name <+> dcolon <+> ty_msg) }+ add_binding_warn :: Id -> RnM ()+ add_binding_warn id =+ when (not_ghc_generated name) $+ do { env <- tcInitTidyEnv -- Why not use emptyTidyEnv?+ ; let (_, ty) = tidyOpenType env (idType id)+ missing = MissingTopLevelBindingSig name ty+ diag = TcRnMissingSignature missing exported warn_binds+ ; addDiagnosticAt (getSrcSpan name) diag } where name = idName id- export_check = warn_binds || name `elemNameSet` exports- flag | warn_binds- = Opt_WarnMissingSignatures- | otherwise- = Opt_WarnMissingExportedSignatures+ exported = if name `elemNameSet` exports+ then IsExported+ else IsNotExported - add_warn name flag msg- = when not_ghc_generated $ do- let dia = TcRnUnknownMessage $- mkPlainDiagnostic (WarningWithFlag flag) noHints msg- addDiagnosticAt (getSrcSpan name) dia+ add_patsyn_warn :: PatSyn -> RnM ()+ add_patsyn_warn ps =+ when (not_ghc_generated name) $+ addDiagnosticAt (getSrcSpan name)+ (TcRnMissingSignature missing exported warn_pat_syns) where- not_ghc_generated- = name `elemNameSet` sig_ns+ name = patSynName ps+ missing = MissingPatSynSig ps+ exported = if name `elemNameSet` exports+ then IsExported+ else IsNotExported - ; add_sig_warns }+ -- Warn about missing signatures+ -- Do this only when we have a type to offer+ -- See Note [Missing signatures]+ ; mapM_ add_binding_warn binds+ ; mapM_ add_patsyn_warn pat_syns+ } -- | Warn the user about tycons that lack kind signatures. -- Called /after/ type (and kind) inference, so that we can report the -- inferred kinds. warnMissingKindSignatures :: TcGblEnv -> RnM () warnMissingKindSignatures gbl_env- = do { warn_missing_kind_sigs <- woptM Opt_WarnMissingKindSignatures- ; cusks_enabled <- xoptM LangExt.CUSKs- ; when (warn_missing_kind_sigs) (mapM_ (add_ty_warn cusks_enabled) tcs)+ = do { cusks_enabled <- xoptM LangExt.CUSKs+ ; mapM_ (add_ty_warn cusks_enabled) tcs } where tcs = tcg_tcs gbl_env ksig_ns = tcg_ksigs gbl_env+ exports = availsToNameSet (tcg_exports gbl_env)+ not_ghc_generated :: Name -> Bool+ not_ghc_generated name = name `elemNameSet` ksig_ns - add_ty_warn :: Bool -> TyCon -> IOEnv (Env TcGblEnv TcLclEnv) ()- add_ty_warn cusks_enabled tyCon = when (name `elemNameSet` ksig_ns) $ do- let dia = TcRnUnknownMessage $- mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingKindSignatures) noHints $- hang msg 2 (text "type" <+> pprPrefixName name <+> dcolon <+> ki_msg)- addDiagnosticAt (getSrcSpan name) dia+ add_ty_warn :: Bool -> TyCon -> RnM ()+ add_ty_warn cusks_enabled tyCon =+ when (not_ghc_generated name) $+ addDiagnosticAt (getSrcSpan name) diag where- msg | cusks_enabled = text "Top-level type constructor with no standalone kind signature or CUSK:"- | otherwise = text "Top-level type constructor with no standalone kind signature:" name = tyConName tyCon- ki = tyConKind tyCon- ki_msg :: SDoc- ki_msg = pprKind ki+ diag = TcRnMissingSignature missing exported False+ missing = MissingTyConKindSig tyCon cusks_enabled+ exported = if name `elemNameSet` exports+ then IsExported+ else IsNotExported {- *********************************************************
compiler/GHC/Rename/Pat.hs view
@@ -52,7 +52,7 @@ import GHC.Tc.Utils.Zonk ( hsOverLitName ) import GHC.Rename.Env import GHC.Rename.Fixity-import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn, bindLocalNames+import GHC.Rename.Utils ( newLocalBndrRn, bindLocalNames , warnUnusedMatches, newLocalBndrRn , checkUnusedRecordWildcard , checkDupNames, checkDupAndShadowedNames@@ -422,7 +422,7 @@ -- Nor can we check incrementally for shadowing, else we'll -- complain *twice* about duplicates e.g. f (x,x) = ... --- -- See note [Don't report shadowing for pattern synonyms]+ -- See Note [Don't report shadowing for pattern synonyms] ; let bndrs = collectPatsBinders CollNoDictBinders pats' ; addErrCtxt doc_pat $ if isPatSynCtxt ctxt
compiler/GHC/Rename/Splice.hs view
@@ -22,7 +22,7 @@ import GHC.Driver.Env.Types import GHC.Rename.Env-import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn )+import GHC.Rename.Utils ( newLocalBndrRn ) import GHC.Rename.Unbound ( isUnboundName ) import GHC.Rename.Module ( rnSrcDecls, findSplice ) import GHC.Rename.Pat ( rnPat )
compiler/GHC/Rename/Unbound.hs view
@@ -232,6 +232,7 @@ ([], []) -> [] ] -- Note [Only-quals]+ -- ~~~~~~~~~~~~~~~~~ -- The second alternative returns those names with the same -- OccName as the one we tried, but live in *qualified* imports -- e.g. if you have:@@ -320,7 +321,7 @@ (helpful_imports_hiding, helpful_imports_non_hiding) = partition (imv_is_hiding . snd) helpful_imports - -- See note [When to show/hide the module-not-imported line]+ -- See Note [When to show/hide the module-not-imported line] show_not_imported_line :: ModuleName -> Bool -- #15611 show_not_imported_line modnam | modnam `elem` glob_mods = False -- #14225 -- 1@@ -400,7 +401,7 @@ promoted_datacons = [(dataName, [WL_Constructor]) | data_kinds] {--Note [Related name space]+Note [Related name spaces] ~~~~~~~~~~~~~~~~~~~~~~~~~ Name spaces are related if there is a chance to mean the one when one writes the other, i.e. variables <-> data constructors and type variables <-> type
compiler/GHC/Rename/Utils.hs view
@@ -18,11 +18,9 @@ warnForallIdentifier, checkUnusedRecordWildcard, mkFieldEnv,- badQualBndrErr, typeAppErr,+ badQualBndrErr, typeAppErr, badFieldConErr, wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType, genHsIntegralLit, genHsTyLit,- HsDocContext(..), pprHsDocContext,- inHsDocContext, withHsDocContext, newLocalBndrRn, newLocalBndrsRn, @@ -43,6 +41,7 @@ import GHC.Hs import GHC.Types.Name.Reader import GHC.Tc.Errors.Types+import GHC.Tc.Errors.Ppr (withHsDocContext) import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Types.Error@@ -616,6 +615,12 @@ <+> quotes (char '@' <> ppr k)) 2 (text "Perhaps you intended to use TypeApplications") +badFieldConErr :: Name -> FieldLabelString -> TcRnMessage+badFieldConErr con field+ = TcRnUnknownMessage $ mkPlainError noHints $+ hsep [text "Constructor" <+> quotes (ppr con),+ text "does not have field", quotes (ppr field)]+ -- | Ensure that a boxed or unboxed tuple has arity no larger than -- 'mAX_TUPLE_SIZE'. checkTupSize :: Int -> TcM ()@@ -671,72 +676,3 @@ genHsTyLit :: FastString -> HsType GhcRn genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText--{--************************************************************************-* *-\subsection{Contexts for renaming errors}-* *-************************************************************************--}---- AZ:TODO: Change these all to be Name instead of RdrName.--- Merge TcType.UserTypeContext in to it.-data HsDocContext- = TypeSigCtx SDoc- | StandaloneKindSigCtx SDoc- | PatCtx- | SpecInstSigCtx- | DefaultDeclCtx- | ForeignDeclCtx (LocatedN RdrName)- | DerivDeclCtx- | RuleCtx FastString- | TyDataCtx (LocatedN RdrName)- | TySynCtx (LocatedN RdrName)- | TyFamilyCtx (LocatedN RdrName)- | FamPatCtx (LocatedN RdrName) -- The patterns of a type/data family instance- | ConDeclCtx [LocatedN Name]- | ClassDeclCtx (LocatedN RdrName)- | ExprWithTySigCtx- | TypBrCtx- | HsTypeCtx- | HsTypePatCtx- | GHCiCtx- | SpliceTypeCtx (LHsType GhcPs)- | ClassInstanceCtx- | GenericCtx SDoc -- Maybe we want to use this more!--withHsDocContext :: HsDocContext -> SDoc -> SDoc-withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt--inHsDocContext :: HsDocContext -> SDoc-inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt--pprHsDocContext :: HsDocContext -> SDoc-pprHsDocContext (GenericCtx doc) = doc-pprHsDocContext (TypeSigCtx doc) = text "the type signature for" <+> doc-pprHsDocContext (StandaloneKindSigCtx doc) = text "the standalone kind signature for" <+> doc-pprHsDocContext PatCtx = text "a pattern type-signature"-pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma"-pprHsDocContext DefaultDeclCtx = text "a `default' declaration"-pprHsDocContext DerivDeclCtx = text "a deriving declaration"-pprHsDocContext (RuleCtx name) = text "the rewrite rule" <+> doubleQuotes (ftext name)-pprHsDocContext (TyDataCtx tycon) = text "the data type declaration for" <+> quotes (ppr tycon)-pprHsDocContext (FamPatCtx tycon) = text "a type pattern of family instance for" <+> quotes (ppr tycon)-pprHsDocContext (TySynCtx name) = text "the declaration for type synonym" <+> quotes (ppr name)-pprHsDocContext (TyFamilyCtx name) = text "the declaration for type family" <+> quotes (ppr name)-pprHsDocContext (ClassDeclCtx name) = text "the declaration for class" <+> quotes (ppr name)-pprHsDocContext ExprWithTySigCtx = text "an expression type signature"-pprHsDocContext TypBrCtx = text "a Template-Haskell quoted type"-pprHsDocContext HsTypeCtx = text "a type argument"-pprHsDocContext HsTypePatCtx = text "a type argument in a pattern"-pprHsDocContext GHCiCtx = text "GHCi input"-pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty)-pprHsDocContext ClassInstanceCtx = text "GHC.Tc.Gen.Splice.reifyInstances"--pprHsDocContext (ForeignDeclCtx name)- = text "the foreign declaration for" <+> quotes (ppr name)-pprHsDocContext (ConDeclCtx [name])- = text "the definition of data constructor" <+> quotes (ppr name)-pprHsDocContext (ConDeclCtx names)- = text "the definition of data constructors" <+> interpp'SP names
compiler/GHC/Runtime/Eval.hs view
@@ -105,6 +105,7 @@ import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSet import GHC.Types.TyThing import GHC.Types.BreakInfo @@ -691,7 +692,7 @@ {- Note [Syncing breakpoint info]-+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ To display the values of the free variables for a single breakpoint, the function `GHC.Runtime.Eval.bindLocalsAtBreakpoint` pulls out the information from the fields `modBreaks_breakInfo` and@@ -1062,22 +1063,18 @@ let dict_var = mkVanillaGlobal dictName theta loc <- getCtLocM (GivenOrigin (getSkolemInfo unkSkol)) Nothing - -- Generate a wanted here because at the end of constraint- -- solving, most derived constraints get thrown away, which in certain- -- cases, notably with quantified constraints makes it impossible to rule- -- out instances as invalid. (See #18071) return CtWanted { ctev_pred = varType dict_var, ctev_dest = EvVarDest dict_var,- ctev_nosh = WDeriv,- ctev_loc = loc+ ctev_loc = loc,+ ctev_rewriters = emptyRewriterSet } -- Find instances where the head unifies with the provided type findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])] findMatchingInstances ty = do ies@(InstEnvs {ie_global = ie_global, ie_local = ie_local}) <- tcGetInstEnvs- let allClasses = instEnvClasses ie_global ++ instEnvClasses ie_local+ let allClasses = uniqDSetToList $ instEnvClasses ie_global `unionUniqDSets` instEnvClasses ie_local return $ concatMap (try_cls ies) allClasses where {- Check that a class instance is well-kinded.@@ -1131,13 +1128,19 @@ -- which otherwise appear as opaque type variables. (See #18262). WC { wc_simple = simples, wc_impl = impls } <- simplifyWantedsTcM wanteds - if allBag allowedSimple simples && solvedImplics impls- then return . Just $ substInstArgs tys (bagToList (mapBag ctPred simples)) clsInst+ -- The simples might contain superclasses. This clutters up the output+ -- (we want e.g. instance Ord a => Ord (Maybe a), not+ -- instance (Ord a, Eq a) => Ord (Maybe a)). So we use mkMinimalBySCs+ let simple_preds = map ctPred (bagToList simples)+ let minimal_simples = mkMinimalBySCs id simple_preds++ if all allowedSimple minimal_simples && solvedImplics impls+ then return . Just $ substInstArgs tys minimal_simples clsInst else return Nothing where- allowedSimple :: Ct -> Bool- allowedSimple ct = isSatisfiablePred (ctPred ct)+ allowedSimple :: PredType -> Bool+ allowedSimple pred = isSatisfiablePred pred solvedImplics :: Bag Implication -> Bool solvedImplics impls = allBag (isSolvedStatus . ic_status) impls@@ -1277,13 +1280,13 @@ obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term obtainTermFromId hsc_env bound force id = do- hv <- Loader.loadName (hscInterp hsc_env) hsc_env Nothing (varName id)+ (hv, _, _) <- Loader.loadName (hscInterp hsc_env) hsc_env (varName id) cvObtainTerm hsc_env bound force (idType id) hv -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type) reconstructType hsc_env bound id = do- hv <- Loader.loadName (hscInterp hsc_env) hsc_env Nothing (varName id)+ (hv, _, _) <- Loader.loadName (hscInterp hsc_env) hsc_env (varName id) cvReconstructType hsc_env bound (idType id) hv mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
compiler/GHC/Runtime/Loader.hs view
@@ -65,14 +65,16 @@ import Control.Monad ( unless ) import Data.Maybe ( mapMaybe ) import Unsafe.Coerce ( unsafeCoerce )-import GHC.Unit.Types (ModuleNameWithIsBoot)+import GHC.Linker.Types+import GHC.Types.Unique.DFM+import Data.List (unzip4) -- | Loads the plugins specified in the pluginModNames field of the dynamic -- flags. Should be called after command line arguments are parsed, but before -- actual compilation starts. Idempotent operation. Should be re-called if -- pluginModNames or pluginModNameOpts changes.-initializePlugins :: HscEnv -> Maybe ModuleNameWithIsBoot -> IO HscEnv-initializePlugins hsc_env mnwib+initializePlugins :: HscEnv -> IO HscEnv+initializePlugins hsc_env -- plugins not changed | loaded_plugins <- loadedPlugins (hsc_plugins hsc_env) , map lpModuleName loaded_plugins == reverse (pluginModNames dflags)@@ -80,8 +82,8 @@ , all same_args loaded_plugins = return hsc_env -- no need to reload plugins FIXME: doesn't take static plugins into account | otherwise- = do loaded_plugins <- loadPlugins hsc_env mnwib- let plugins' = (hsc_plugins hsc_env) { loadedPlugins = loaded_plugins }+ = do (loaded_plugins, links, pkgs) <- loadPlugins hsc_env+ let plugins' = (hsc_plugins hsc_env) { loadedPlugins = loaded_plugins, loadedPluginDeps = (links, pkgs) } let hsc_env' = hsc_env { hsc_plugins = plugins' } withPlugins (hsc_plugins hsc_env') driverPlugin hsc_env' where@@ -90,12 +92,14 @@ argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst) dflags = hsc_dflags hsc_env -loadPlugins :: HscEnv -> Maybe ModuleNameWithIsBoot -> IO [LoadedPlugin]-loadPlugins hsc_env mnwib+loadPlugins :: HscEnv -> IO ([LoadedPlugin], [Linkable], PkgsLoaded)+loadPlugins hsc_env = do { unless (null to_load) $ checkExternalInterpreter hsc_env- ; plugins <- mapM loadPlugin to_load- ; return $ zipWith attachOptions to_load plugins }+ ; plugins_with_deps <- mapM loadPlugin to_load+ ; let (plugins, ifaces, links, pkgs) = unzip4 plugins_with_deps+ ; return (zipWith attachOptions to_load (zip plugins ifaces), concat links, foldl' plusUDFM emptyUDFM pkgs)+ } where dflags = hsc_dflags hsc_env to_load = reverse $ pluginModNames dflags@@ -105,14 +109,16 @@ where options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags , opt_mod_nm == mod_nm ]- loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName hsc_env mnwib+ loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName hsc_env -loadFrontendPlugin :: HscEnv -> ModuleName -> IO FrontendPlugin+loadFrontendPlugin :: HscEnv -> ModuleName -> IO (FrontendPlugin, [Linkable], PkgsLoaded) loadFrontendPlugin hsc_env mod_name = do checkExternalInterpreter hsc_env- fst <$> loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName- hsc_env Nothing mod_name+ (plugin, _iface, links, pkgs)+ <- loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName+ hsc_env mod_name+ return (plugin, links, pkgs) -- #14335 checkExternalInterpreter :: HscEnv -> IO ()@@ -121,8 +127,8 @@ -> throwIO (InstallationError "Plugins require -fno-external-interpreter") _ -> pure () -loadPlugin' :: OccName -> Name -> HscEnv -> Maybe ModuleNameWithIsBoot -> ModuleName -> IO (a, ModIface)-loadPlugin' occ_name plugin_name hsc_env mnwib mod_name+loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface, [Linkable], PkgsLoaded)+loadPlugin' occ_name plugin_name hsc_env mod_name = do { let plugin_rdr_name = mkRdrQual mod_name occ_name dflags = hsc_dflags hsc_env ; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name@@ -136,7 +142,7 @@ Just (name, mod_iface) -> do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name- ; eith_plugin <- getValueSafely hsc_env mnwib name (mkTyConTy plugin_tycon)+ ; eith_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon) ; case eith_plugin of Left actual_type -> throwGhcExceptionIO (CmdLineError $@@ -147,7 +153,7 @@ , text "did not have the type" , text "GHC.Plugins.Plugin" , text "as required"])- Right plugin -> return (plugin, mod_iface) } } }+ Right (plugin, links, pkgs) -> return (plugin, mod_iface, links, pkgs) } } } -- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used@@ -192,23 +198,23 @@ -- * If the Name does not exist in the module -- * If the link failed -getValueSafely :: HscEnv -> Maybe ModuleNameWithIsBoot -> Name -> Type -> IO (Either Type a)-getValueSafely hsc_env mnwib val_name expected_type = do+getValueSafely :: HscEnv -> Name -> Type -> IO (Either Type (a, [Linkable], PkgsLoaded))+getValueSafely hsc_env val_name expected_type = do eith_hval <- case getValueSafelyHook hooks of- Nothing -> getHValueSafely interp hsc_env mnwib val_name expected_type- Just h -> h hsc_env mnwib val_name expected_type+ Nothing -> getHValueSafely interp hsc_env val_name expected_type+ Just h -> h hsc_env val_name expected_type case eith_hval of Left actual_type -> return (Left actual_type)- Right hval -> do+ Right (hval, links, pkgs) -> do value <- lessUnsafeCoerce logger "getValueSafely" hval- return (Right value)+ return (Right (value, links, pkgs)) where interp = hscInterp hsc_env logger = hsc_logger hsc_env hooks = hsc_hooks hsc_env -getHValueSafely :: Interp -> HscEnv -> Maybe ModuleNameWithIsBoot -> Name -> Type -> IO (Either Type HValue)-getHValueSafely interp hsc_env mnwib val_name expected_type = do+getHValueSafely :: Interp -> HscEnv -> Name -> Type -> IO (Either Type (HValue, [Linkable], PkgsLoaded))+getHValueSafely interp hsc_env val_name expected_type = do forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name -- Now look up the names for the value and type constructor in the type environment mb_val_thing <- lookupType hsc_env val_name@@ -221,13 +227,14 @@ then do -- Link in the module that contains the value, if it has such a module case nameModule_maybe val_name of- Just mod -> do loadModule interp hsc_env mnwib mod+ Just mod -> do loadModule interp hsc_env mod return () Nothing -> return () -- Find the value that we just linked in and cast it given that we have proved it's type hval <- do- v <- loadName interp hsc_env mnwib val_name- wormhole interp v+ (v, links, pkgs) <- loadName interp hsc_env val_name+ hv <- wormhole interp v+ return (hv, links, pkgs) return (Right hval) else return (Left (idType id)) Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing
compiler/GHC/Stg/CSE.hs view
@@ -11,8 +11,8 @@ This was originally reported as #9291. There are two types of common code occurrences that we aim for, see-note [Case 1: CSEing allocated closures] and-note [Case 2: CSEing case binders] below.+Note [Case 1: CSEing allocated closures] and+Note [Case 2: CSEing case binders] below. Note [Case 1: CSEing allocated closures]@@ -147,7 +147,7 @@ -- The CSE Env -- ----------------- --- | The CSE environment. See note [CseEnv Example]+-- | The CSE environment. See Note [CseEnv Example] data CseEnv = CseEnv { ce_conAppMap :: ConAppMap OutId -- ^ The main component of the environment is the trie that maps@@ -245,7 +245,7 @@ ------------------- forgetCse :: CseEnv -> CseEnv forgetCse env = env { ce_conAppMap = emptyTM }- -- See note [Free variables of an StgClosure]+ -- See Note [Free variables of an StgClosure] addSubst :: OutId -> OutId -> CseEnv -> CseEnv addSubst from to env@@ -387,7 +387,7 @@ = addDataCon case_bndr dataCon (map StgVarArg args') env1 | otherwise = env1- -- see note [Case 2: CSEing case binders]+ -- see Note [Case 2: CSEing case binders] rhs' = stgCseExpr env2 rhs in (DataAlt dataCon, args', rhs') stgCseAlt env _ _ (altCon, args, rhs)@@ -427,14 +427,14 @@ in (Nothing, env') | otherwise = let env' = addDataCon bndr dataCon args' env- -- see note [Case 1: CSEing allocated closures]+ -- see Note [Case 1: CSEing allocated closures] pair = (bndr, StgRhsCon ccs dataCon mu ticks args') in (Just pair, env') where args' = substArgs env args stgCseRhs env bndr (StgRhsClosure ext ccs upd args body) = let (env1, args') = substBndrs env args- env2 = forgetCse env1 -- See note [Free variables of an StgClosure]+ env2 = forgetCse env1 -- See Note [Free variables of an StgClosure] body' = stgCseExpr env2 body in (Just (substVar env bndr, StgRhsClosure ext ccs upd args' body'), env)
compiler/GHC/Stg/Debug.hs view
@@ -1,8 +1,11 @@ {-# LANGUAGE TupleSections #-}+ -- This module contains functions which implement -- the -finfo-table-map and -fdistinct-constructor-tables flags-module GHC.Stg.Debug(collectDebugInformation) where-+module GHC.Stg.Debug+ ( StgDebugOpts(..)+ , collectDebugInformation+ ) where import GHC.Prelude @@ -15,7 +18,6 @@ import GHC.Unit.Module import GHC.Types.Name ( getName, getOccName, occNameString, nameSrcSpan) import GHC.Data.FastString-import GHC.Driver.Session import Control.Monad (when) import Control.Monad.Trans.Reader@@ -29,8 +31,13 @@ data SpanWithLabel = SpanWithLabel RealSrcSpan String -data R = R { rDynFlags :: DynFlags, rModLocation :: ModLocation, rSpan :: Maybe SpanWithLabel }+data StgDebugOpts = StgDebugOpts+ { stgDebug_infoTableMap :: !Bool+ , stgDebug_distinctConstructorTables :: !Bool+ } +data R = R { rOpts :: StgDebugOpts, rModLocation :: ModLocation, rSpan :: Maybe SpanWithLabel }+ type M a = ReaderT R (State InfoTableProvMap) a withSpan :: IpeSourceLocation -> M a -> M a@@ -44,9 +51,9 @@ maybe_replace r = r { rSpan = Just (SpanWithLabel new_s new_l) } -collectDebugInformation :: DynFlags -> ModLocation -> [StgTopBinding] -> ([StgTopBinding], InfoTableProvMap)-collectDebugInformation dflags ml bs =- runState (runReaderT (mapM collectTop bs) (R dflags ml Nothing)) emptyInfoTableProvMap+collectDebugInformation :: StgDebugOpts -> ModLocation -> [StgTopBinding] -> ([StgTopBinding], InfoTableProvMap)+collectDebugInformation opts ml bs =+ runState (runReaderT (mapM collectTop bs) (R opts ml Nothing)) emptyInfoTableProvMap collectTop :: StgTopBinding -> M StgTopBinding collectTop (StgTopLifted t) = StgTopLifted <$> collectStgBind t@@ -62,7 +69,14 @@ collectStgRhs :: Id -> StgRhs -> M StgRhs collectStgRhs bndr (StgRhsClosure ext cc us bs e)= do- e' <- collectExpr e+ let+ name = idName bndr+ -- If the name has a span, use that initially as the source position in-case+ -- we don't get anything better.+ with_span = case nameSrcSpan name of+ RealSrcSpan pos _ -> withSpan (pos, occNameString (getOccName name))+ _ -> id+ e' <- with_span $ collectExpr e recordInfo bndr e' return $ StgRhsClosure ext cc us bs e' collectStgRhs _bndr (StgRhsCon cc dc _mn ticks args) = do@@ -128,8 +142,8 @@ recordStgIdPosition :: Id -> Maybe SpanWithLabel -> Maybe SpanWithLabel -> M () recordStgIdPosition id best_span ss = do- dflags <- asks rDynFlags- when (gopt Opt_InfoTableMap dflags) $ do+ opts <- asks rOpts+ when (stgDebug_infoTableMap opts) $ do cc <- asks rSpan --Useful for debugging why a certain Id gets given a certain span --pprTraceM "recordStgIdPosition" (ppr id $$ ppr cc $$ ppr best_span $$ ppr ss)@@ -142,8 +156,8 @@ numberDataCon dc _ | isUnboxedTupleDataCon dc = return NoNumber numberDataCon dc _ | isUnboxedSumDataCon dc = return NoNumber numberDataCon dc ts = do- dflags <- asks rDynFlags- if not (gopt Opt_DistinctConstructorTables dflags) then return NoNumber else do+ opts <- asks rOpts+ if not (stgDebug_distinctConstructorTables opts) then return NoNumber else do env <- lift get mcc <- asks rSpan let !mbest_span = (\(SpanWithLabel rss l) -> (rss, l)) <$> (selectTick ts <|> mcc)
compiler/GHC/Stg/FVs.hs view
@@ -47,6 +47,7 @@ import GHC.Prelude hiding (mod) import GHC.Stg.Syntax+import GHC.Stg.Utils (bindersOf) import GHC.Types.Id import GHC.Types.Name (Name, nameIsLocalOrFrom) import GHC.Types.Tickish ( GenTickish(Breakpoint) )
+ compiler/GHC/Stg/InferTags.hs view
@@ -0,0 +1,631 @@+{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+ -- To permit: type instance XLet 'InferTaggedBinders = XLet 'SomePass++{-# OPTIONS_GHC -Wname-shadowing #-}+module GHC.Stg.InferTags ( inferTags ) where++import GHC.Prelude hiding (id)++import GHC.Core.DataCon+import GHC.Core.Type+import GHC.Types.Id+import GHC.Types.Id.Info (tagSigInfo)+import GHC.Types.Name+import GHC.Stg.Syntax+import GHC.Types.Basic ( CbvMark (..) )+import GHC.Types.Unique.Supply (mkSplitUniqSupply)+import GHC.Types.RepType (dataConRuntimeRepStrictness)+import GHC.Core (AltCon(..))+import Data.List (mapAccumL)+import GHC.Utils.Outputable+import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull )++import GHC.Stg.InferTags.Types+import GHC.Stg.InferTags.Rewrite (rewriteTopBinds)+import Data.Maybe+import GHC.Types.Name.Env (mkNameEnv, NameEnv)+import GHC.Driver.Config.Stg.Ppr+import GHC.Driver.Session+import GHC.Utils.Logger+import qualified GHC.Unit.Types++{- Note [Tag Inference]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The purpose of this pass is to attach to every binder a flag+to indicate whether or not it is "properly tagged". A binder+is properly tagged if it is guaranteed:+ - to point to a heap-allocated *value*+ - and to have the tag of the value encoded in the pointer++For example+ let x = Just y in ...++Here x will be properly tagged: it will point to the heap-allocated+values for (Just y), and the tag-bits of the pointer will encode+the tag for Just so there is no need to re-enter the closure or even+check for the presence of tag bits. The impacts of this can be very large.++For containers the reduction in runtimes with this optimization was as follows:++intmap-benchmarks: 89.30%+intset-benchmarks: 90.87%+map-benchmarks: 88.00%+sequence-benchmarks: 99.84%+set-benchmarks: 85.00%+set-operations-intmap:88.64%+set-operations-map: 74.23%+set-operations-set: 76.50%+lookupge-intmap: 89.57%+lookupge-map: 70.95%++With nofib being ~0.3% faster as well.++See Note [Tag inference passes] for how we proceed to generate and use this information.++Note [Strict Field Invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As part of tag inference we introduce the Strict Field Invariant.+Which consists of us saying that:++* Pointers in strict fields must (a) point directly to the value, and+ (b) must be properly tagged.++For example, given+ data T = MkT ![Int]++the Strict Field Invariant guarantees that the first field of any `MkT` constructor+will either point directly to nil, or directly to a cons cell;+and will be tagged with `001` or `010` respectively.+It will never point to a thunk, nor will it be tagged `000` (meaning "might be a thunk").+NB: Note that the proper tag for some objects is indeed `000`. Currently this is the case for PAPs.++Why do we care? Because if we have code like:++case strictPair of+ SP x y ->+ case x of ...++It allows us to safely omit the code to enter x and the check+for the presence of a tag that goes along with it.+However we might still branch on the tag as usual.+See Note [Tag Inference] for how much impact this can have for+some code.++This is enforced by the code GHC.Stg.InferTags.Rewrite+where we:++* Look at all constructor allocations.+* Check if arguments to their strict fields are known to be properly tagged+* If not we convert `StrictJust x` into `case x of x' -> StrictJust x'`++This is usually very beneficial but can cause regressions in rare edge cases where+we fail to proof that x is properly tagged, or where it simply isn't.+See Note [How untagged pointers can end up in strict fields] for how the second case+can arise.++For a full example of the worst case consider this code:++foo ... = ...+ let c = StrictJust x+ in ...++Here we would rewrite `let c = StrictJust x` into `let c = case x of x' -> StrictJust x'`+However that is horrible! We end up allocating a thunk for `c` first, which only when+evaluated will allocate the constructor.++So we do our best to establish that `x` is already tagged (which it almost always is)+to avoid this cost. In my benchmarks I haven't seen any cases where this causes regressions.++Note [How untagged pointers can end up in strict fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+ data Set a = Tip | Bin !a (Set a) (Set a)++We make a wrapper for Bin that evaluates its arguments+ $WBin x a b = case x of xv -> Bin xv a b+Here `xv` will always be evaluated and properly tagged, just as the+Strict Field Invariant requires.++But alas the Simplifier can destroy the invariant: see #15696.+We start with+ thk = f ()+ g x = ...(case thk of xv -> Bin xv Tip Tip)...++So far so good; the argument to Bin (which is strict) is evaluated.+Now we do float-out. And in doing so we do a reverse binder-swap (see+Note [Binder-swap during float-out] in SetLevels) thus++ g x = ...(case thk of xv -> Bin thk Nil Nil)...++The goal of the reverse binder-swap is to allow more floating -- and+indeed it does! We float the Bin to top level:++ lvl = Bin thk Tip Tip+ g x = ...(case thk of xv -> lvl)...++Now you can see that the argument of Bin, namely thk, points to the+thunk, not to the value as it did before.++In short, although it may be rare, the output of optimisation passes+cannot guarantee to obey the Strict Field Invariant. For this reason+we run tag inference. See Note [Tag inference passes].++Note [Tag inference passes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Tag inference proceeds in two passes:+* The first pass is an analysis to compute which binders are properly tagged.+ The result is then attached to /binders/.+ This is implemented by `inferTagsAnal` in GHC.Stg.InferTags+* The second pass walks over the AST checking if the Strict Field Invariant is upheld.+ See Note [Strict Field Invariant].+ If required this pass modifies the program to uphold this invariant.+ Tag information is also moved from /binders/ to /occurrences/ during this pass.+ This is done by `GHC.Stg.InferTags.Rewrite (rewriteTopBinds)`.+* Finally the code generation uses this information to skip the thunk check when branching on+ values. This is done by `cgExpr`/`cgCase` in the backend.++Last but not least we also export the tag sigs of top level bindings to allow this optimization+ to work across module boundaries.++Note [TagInfo of functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+The purpose of tag inference is really to figure out when we don't have to enter+value closures. There the meaning of the tag is fairly obvious.+For functions we never make use of the tag info so we have two choices:+* Treat them as TagDunno+* Treat them as TagProper (as they *are* tagged with their arity) and be really+ careful to make sure we still enter them when needed.+As it makes little difference for runtime performance I've treated functions as TagDunno in a few places where+it made the code simpler. But besides implementation complexity there isn't any reason+why we couldn't be more rigourous in dealing with functions.++Note [Tag inference debugging]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is a flag -dtag-inference-checks which inserts various+compile/runtime checks in order to ensure the Strict Field Invariant+holds. It should cover all places+where tags matter and disable optimizations which interfere with checking+the invariant like generation of AP-Thunks.++Note [Polymorphic StgPass for inferTagExpr]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In order to reach a fixpoint we sometimes have to re-analyse an expression+multiple times. But after the initial run the Ast will be parameterized by+a different StgPass! To handle this a large part of the analysis is polymorphic+over the exact StgPass we are using. Which allows us to run the analysis on+the output of itself.++-}++{- *********************************************************************+* *+ Tag inference pass+* *+********************************************************************* -}++-- doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]+-- -> CollectedCCs+-- -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs+-- -> HpcInfo+-- -> IO (Stream IO CmmGroupSRTs CgInfos)+-- -- Note we produce a 'Stream' of CmmGroups, so that the+-- -- backend can be run incrementally. Otherwise it generates all+-- -- the C-- up front, which has a significant space cost.+inferTags :: DynFlags -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig)+inferTags dflags logger this_mod stg_binds = do++ -- Annotate binders with tag information.+ let (!stg_binds_w_tags) = {-# SCC "StgTagFields" #-}+ inferTagsAnal stg_binds+ putDumpFileMaybe logger Opt_D_dump_stg_tags "CodeGenAnal STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_tags)++ let export_tag_info = collectExportInfo stg_binds_w_tags++ -- Rewrite STG to uphold the strict field invariant+ us_t <- mkSplitUniqSupply 't'+ let rewritten_binds = {-# SCC "StgTagRewrite" #-} rewriteTopBinds this_mod us_t stg_binds_w_tags :: [TgStgTopBinding]++ return (rewritten_binds,export_tag_info)++{- *********************************************************************+* *+ Main inference algorithm+* *+********************************************************************* -}++type OutputableInferPass p = (Outputable (TagEnv p)+ , Outputable (GenStgExpr p)+ , Outputable (BinderP p)+ , Outputable (GenStgRhs p))++-- | This constraint encodes the fact that no matter what pass+-- we use the Let/Closure extension points are the same as these for+-- 'InferTaggedBinders.+type InferExtEq i = ( XLet i ~ XLet 'InferTaggedBinders+ , XLetNoEscape i ~ XLetNoEscape 'InferTaggedBinders+ , XRhsClosure i ~ XRhsClosure 'InferTaggedBinders)++inferTagsAnal :: [GenStgTopBinding 'CodeGen] -> [GenStgTopBinding 'InferTaggedBinders]+inferTagsAnal binds =+ -- pprTrace "Binds" (pprGenStgTopBindings shortStgPprOpts $ binds) $+ snd (mapAccumL inferTagTopBind initEnv binds)++-----------------------+inferTagTopBind :: TagEnv 'CodeGen -> GenStgTopBinding 'CodeGen+ -> (TagEnv 'CodeGen, GenStgTopBinding 'InferTaggedBinders)+inferTagTopBind env (StgTopStringLit id bs)+ = (env, StgTopStringLit id bs)+inferTagTopBind env (StgTopLifted bind)+ = (env', StgTopLifted bind')+ where+ (env', bind') = inferTagBind env bind+++-- Why is this polymorphic over the StgPass? See Note [Polymorphic StgPass for inferTagExpr]+-----------------------+inferTagExpr :: forall p. (OutputableInferPass p, InferExtEq p)+ => TagEnv p -> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders)+inferTagExpr env (StgApp fun args)+ = --pprTrace "inferTagExpr1"+ -- (ppr fun <+> ppr args $$ ppr info $$+ -- text "deadEndInfo:" <> ppr (isDeadEndId fun, idArity fun, length args)+ -- )+ (info, StgApp fun args)+ where+ !fun_arity = idArity fun+ info | fun_arity == 0 -- Unknown arity => Thunk or unknown call+ = TagDunno++ | isDeadEndId fun+ , fun_arity == length args -- Implies we will simply call the function.+ = TagTagged -- See Note [Bottom functions are TagTagged]++ | Just (TagSig res_info) <- tagSigInfo (idInfo fun)+ , fun_arity == length args -- Saturated+ = res_info++ | Just (TagSig res_info) <- lookupSig env fun+ , fun_arity == length args -- Saturated+ = res_info++ | otherwise+ = --pprTrace "inferAppUnknown" (ppr fun) $+ TagDunno+-- TODO:+-- If we have something like:+-- let x = thunk in+-- f g = case g of g' -> (# x, g' #)+-- then we *do* know that g' will be properly tagged,+-- so we should return TagTagged [TagDunno,TagProper] but currently we infer+-- TagTagged [TagDunno,TagDunno] because of the unknown arity case in inferTagExpr.+-- Seems not to matter much but should be changed eventually.++inferTagExpr env (StgConApp con cn args tys)+ = (inferConTag env con args, StgConApp con cn args tys)++inferTagExpr _ (StgLit l)+ = (TagTagged, StgLit l)++inferTagExpr env (StgTick tick body)+ = (info, StgTick tick body')+ where+ (info, body') = inferTagExpr env body++inferTagExpr _ (StgOpApp op args ty)+ = -- Do any primops guarantee to return a properly tagged value?+ -- I think not. Ditto foreign calls.+ (TagDunno, StgOpApp op args ty)++inferTagExpr env (StgLet ext bind body)+ = (info, StgLet ext bind' body')+ where+ (env', bind') = inferTagBind env bind+ (info, body') = inferTagExpr env' body++inferTagExpr env (StgLetNoEscape ext bind body)+ = (info, StgLetNoEscape ext bind' body')+ where+ (env', bind') = inferTagBind env bind+ (info, body') = inferTagExpr env' body++inferTagExpr in_env (StgCase scrut bndr ty alts)+ -- Unboxed tuples get their info from the expression we scrutinise if any+ | [(DataAlt con, bndrs, rhs)] <- alts+ , isUnboxedTupleDataCon con+ , Just infos <- scrut_infos bndrs+ , let bndrs' = zipWithEqual "inferTagExpr" mk_bndr bndrs infos+ mk_bndr :: BinderP p -> TagInfo -> (Id, TagSig)+ mk_bndr tup_bndr tup_info =+ -- pprTrace "mk_ubx_bndr_info" ( ppr bndr <+> ppr info ) $+ (getBinderId in_env tup_bndr, TagSig tup_info)+ -- no case binder in alt_env here, unboxed tuple binders are dead after unarise+ alt_env = extendSigEnv in_env bndrs'+ (info, rhs') = inferTagExpr alt_env rhs+ =+ -- pprTrace "inferCase1" (+ -- text "scrut:" <> ppr scrut $$+ -- text "bndr:" <> ppr bndr $$+ -- text "infos" <> ppr infos $$+ -- text "out_bndrs" <> ppr bndrs') $+ (info, StgCase scrut' (noSig in_env bndr) ty [(DataAlt con, bndrs', rhs')])++ | null alts -- Empty case, but I might just be paranoid.+ = -- pprTrace "inferCase2" empty $+ (TagDunno, StgCase scrut' bndr' ty [])+ -- More than one alternative OR non-TagTuple single alternative.+ | otherwise+ =+ let+ case_env = extendSigEnv in_env [bndr']++ (infos, alts')+ = unzip [ (info, (con, bndrs', rhs'))+ | (con, bndrs, rhs) <- alts+ , let (alt_env,bndrs') = addAltBndrInfo case_env con bndrs+ (info, rhs') = inferTagExpr alt_env rhs+ ]+ alt_info = foldr combineAltInfo TagTagged infos+ in ( alt_info, StgCase scrut' bndr' ty alts')+ where+ -- Single unboxed tuple alternative+ scrut_infos bndrs = case scrut_info of+ TagTagged -> Just $ replicate (length bndrs) TagProper+ TagTuple infos -> Just infos+ _ -> Nothing+ (scrut_info, scrut') = inferTagExpr in_env scrut+ bndr' = (getBinderId in_env bndr, TagSig TagProper)++-- Compute binder sigs based on the constructors strict fields.+-- NB: Not used if we have tuple info from the scrutinee.+addAltBndrInfo :: forall p. TagEnv p -> AltCon -> [BinderP p] -> (TagEnv p, [BinderP 'InferTaggedBinders])+addAltBndrInfo env (DataAlt con) bndrs+ | not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)+ = (out_env, out_bndrs)+ where+ marks = dataConRuntimeRepStrictness con :: [StrictnessMark]+ out_bndrs = zipWith mk_bndr bndrs marks+ out_env = extendSigEnv env out_bndrs++ mk_bndr :: (BinderP p -> StrictnessMark -> (Id, TagSig))+ mk_bndr bndr mark+ | isUnliftedType (idType id) || isMarkedStrict mark+ = (id, TagSig TagProper)+ | otherwise+ = noSig env bndr+ where+ id = getBinderId env bndr++addAltBndrInfo env _ bndrs = (env, map (noSig env) bndrs)++-----------------------------+inferTagBind :: (OutputableInferPass p, InferExtEq p)+ => TagEnv p -> GenStgBinding p -> (TagEnv p, GenStgBinding 'InferTaggedBinders)+inferTagBind in_env (StgNonRec bndr rhs)+ =+ -- pprTrace "inferBindNonRec" (+ -- ppr bndr $$+ -- ppr (isDeadEndId id) $$+ -- ppr sig)+ (env', StgNonRec (id, sig) rhs')+ where+ id = getBinderId in_env bndr+ env' = extendSigEnv in_env [(id, sig)]+ (sig,rhs') = inferTagRhs id in_env rhs++inferTagBind in_env (StgRec pairs)+ = -- pprTrace "rec" (ppr (map fst pairs) $$ ppr (in_env { te_env = out_env }, StgRec pairs')) $+ (in_env { te_env = out_env }, StgRec pairs')+ where+ (bndrs, rhss) = unzip pairs+ in_ids = map (getBinderId in_env) bndrs+ init_sigs = map (initSig) $ zip in_ids rhss+ (out_env, pairs') = go in_env init_sigs rhss++ go :: forall q. (OutputableInferPass q , InferExtEq q) => TagEnv q -> [TagSig] -> [GenStgRhs q]+ -> (TagSigEnv, [((Id,TagSig), GenStgRhs 'InferTaggedBinders)])+ go go_env in_sigs go_rhss+ -- | pprTrace "go" (ppr in_ids $$ ppr in_sigs $$ ppr out_sigs $$ ppr rhss') False+ -- = undefined+ | in_sigs == out_sigs = (te_env rhs_env, out_bndrs `zip` rhss')+ | otherwise = go env' out_sigs rhss'+ where+ out_bndrs = map updateBndr in_bndrs -- TODO: Keeps in_ids alive+ in_bndrs = in_ids `zip` in_sigs+ rhs_env = extendSigEnv go_env in_bndrs+ (out_sigs, rhss') = unzip (zipWithEqual "inferTagBind" anaRhs in_ids go_rhss)+ env' = makeTagged go_env++ anaRhs :: Id -> GenStgRhs q -> (TagSig, GenStgRhs 'InferTaggedBinders)+ anaRhs bnd rhs = inferTagRhs bnd rhs_env rhs++ updateBndr :: (Id,TagSig) -> (Id,TagSig)+ updateBndr (v,sig) = (setIdTagSig v sig, sig)++initSig :: forall p. (Id, GenStgRhs p) -> TagSig+-- Initial signature for the fixpoint loop+initSig (_bndr, StgRhsCon {}) = TagSig TagTagged+initSig (bndr, StgRhsClosure _ _ _ _ _) =+ fromMaybe defaultSig (idTagSig_maybe bndr)+ where defaultSig = (TagSig TagTagged)++{- Note [Bottom functions are TagTagged]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have a function with two branches with one+being bottom, and the other returning a tagged+unboxed tuple what is the result? We give it TagTagged!+To answer why consider this function:++foo :: Bool -> (# Bool, Bool #)+foo x = case x of+ True -> (# True,True #)+ False -> undefined++The true branch is obviously tagged. The other branch isn't.+We want to treat the *result* of foo as tagged as well so that+the combination of the branches also is tagged if all non-bottom+branches are tagged.+This is safe because the function is still always called/entered as long+as it's applied to arguments. Since the function will never return we can give+it safely any tag sig we like.+So we give it TagTagged, as it allows the combined tag sig of the case expression+to be the combination of all non-bottoming branches.++-}++-----------------------------+inferTagRhs :: forall p.+ (OutputableInferPass p, InferExtEq p)+ => Id -- ^ Id we are binding to.+ -> TagEnv p -- ^+ -> GenStgRhs p -- ^+ -> (TagSig, GenStgRhs 'InferTaggedBinders)+inferTagRhs bnd_id in_env (StgRhsClosure ext cc upd bndrs body)+ | isDeadEndId bnd_id && (notNull) bndrs+ -- See Note [Bottom functions are TagTagged]+ = (TagSig TagTagged, StgRhsClosure ext cc upd out_bndrs body')+ | otherwise+ = --pprTrace "inferTagRhsClosure" (ppr (_top, _grp_ids, env,info')) $+ (TagSig info', StgRhsClosure ext cc upd out_bndrs body')+ where+ out_bndrs+ | Just marks <- idCbvMarks_maybe bnd_id+ -- Sometimes an we eta-expand foo with additional arguments after ww, and we also trim+ -- the list of marks to the last strict entry. So we can conservatively+ -- assume these are not strict+ = zipWith (mkArgSig) bndrs (marks ++ repeat NotMarkedCbv)+ | otherwise = map (noSig env') bndrs :: [(Id,TagSig)]++ env' = extendSigEnv in_env out_bndrs+ (info, body') = inferTagExpr env' body+ info'+ -- It's a thunk+ | null bndrs+ = TagDunno+ -- TODO: We could preserve tuple fields for thunks+ -- as well. But likely not worth the complexity.++ | otherwise = info++ mkArgSig :: BinderP p -> CbvMark -> (Id,TagSig)+ mkArgSig bndp mark =+ let id = getBinderId in_env bndp+ tag = case mark of+ MarkedCbv -> TagProper+ _+ | isUnliftedType (idType id) -> TagProper+ | otherwise -> TagDunno+ in (id, TagSig tag)++inferTagRhs _ env _rhs@(StgRhsCon cc con cn ticks args)+-- Constructors, which have untagged arguments to strict fields+-- become thunks. We encode this by giving changing RhsCon nodes the info TagDunno+ = --pprTrace "inferTagRhsCon" (ppr grp_ids) $+ (TagSig (inferConTag env con args), StgRhsCon cc con cn ticks args)++{- Note [Constructor TagSigs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+@inferConTag@ will infer the proper tag signature for a binding who's RHS is a constructor+or a StgConApp expression.+Usually these will simply be TagProper. But there are exceptions.+If any of the fields in the constructor are strict, but any argument to these+fields is not tagged then we will have to case on the argument before storing+in the constructor. Which means for let bindings the RHS turns into a thunk+which obviously is no longer properly tagged.+For example we might start with:++ let x<TagDunno> = f ...+ let c<TagProper> = StrictPair x True++But we know during the rewrite stage x will need to be evaluated in the RHS+of `c` so we will infer:++ let x<TagDunno> = f ...+ let c<TagDunno> = StrictPair x True++Which in the rewrite stage will then be rewritten into:++ let x<TagDunno> = f ...+ let c<TagDunno> = case x of x' -> StrictPair x' True++The other exception is unboxed tuples. These will get a TagTuple+signature with a list of TagInfo about their individual binders+as argument. As example:++ let c<TagProper> = True+ let x<TagDunno> = ...+ let f<?> z = case z of z'<TagProper> -> (# c, x #)++Here we will infer for f the Signature <TagTuple[TagProper,TagDunno]>.+This information will be used if we scrutinze a saturated application of+`f` in order to determine the taggedness of the result.+That is for `case f x of (# r1,r2 #) -> rhs` we can infer+r1<TagProper> and r2<TagDunno> which allows us to skip all tag checks on `r1`+in `rhs`.++Things get a bit more complicated with nesting:++ let closeFd<TagTuple[...]> = ...+ let f x = ...+ case x of+ _ -> Solo# closeFd++The "natural" signature for the Solo# branch in `f` would be <TagTuple[TagTuple[...]]>.+But we flatten this out to <TagTuple[TagDunno]> for the time being as it improves compile+time and there doesn't seem to huge benefit to doing differently.++ -}++-- See Note [Constructor TagSigs]+inferConTag :: TagEnv p -> DataCon -> [StgArg] -> TagInfo+inferConTag env con args+ | isUnboxedTupleDataCon con+ = TagTuple $ map (flatten_arg_tag . lookupInfo env) args+ | otherwise =+ -- pprTrace "inferConTag"+ -- ( text "con:" <> ppr con $$+ -- text "args:" <> ppr args $$+ -- text "marks:" <> ppr (dataConRuntimeRepStrictness con) $$+ -- text "arg_info:" <> ppr (map (lookupInfo env) args) $$+ -- text "info:" <> ppr info) $+ info+ where+ info = if any arg_needs_eval strictArgs then TagDunno else TagProper+ strictArgs = zipEqual "inferTagRhs" args (dataConRuntimeRepStrictness con) :: ([(StgArg, StrictnessMark)])+ arg_needs_eval (arg,strict)+ -- lazy args+ | not (isMarkedStrict strict) = False+ | tag <- (lookupInfo env arg)+ -- banged args need to be tagged, or require eval+ = not (isTaggedInfo tag)++ flatten_arg_tag (TagTagged) = TagProper+ flatten_arg_tag (TagProper ) = TagProper+ flatten_arg_tag (TagTuple _) = TagDunno -- See Note [Constructor TagSigs]+ flatten_arg_tag (TagDunno) = TagDunno+++collectExportInfo :: [GenStgTopBinding 'InferTaggedBinders] -> NameEnv TagSig+collectExportInfo binds =+ mkNameEnv bndr_info+ where+ bndr_info = concatMap collect binds :: [(Name,TagSig)]++ collect (StgTopStringLit {}) = []+ collect (StgTopLifted bnd) =+ case bnd of+ StgNonRec (id,sig) _rhs+ | TagSig TagDunno <- sig -> []+ | otherwise -> [(idName id,sig)]+ StgRec bnds -> collectRec bnds++ collectRec :: [(BinderP 'InferTaggedBinders, rhs)] -> [(Name,TagSig)]+ collectRec [] = []+ collectRec (bnd:bnds)+ | (p,_rhs) <- bnd+ , (id,sig) <- p+ , TagSig TagDunno <- sig+ = (idName id,sig) : collectRec bnds+ | otherwise = collectRec bnds
+ compiler/GHC/Stg/InferTags/Rewrite.hs view
@@ -0,0 +1,494 @@+--+-- Copyright (c) 2019 Andreas Klebinger+--++{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}++module GHC.Stg.InferTags.Rewrite (rewriteTopBinds)+where++import GHC.Prelude++import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.Unique.Supply+import GHC.Types.Unique.FM+import GHC.Types.RepType+import GHC.Unit.Types (Module)++import GHC.Core.DataCon+import GHC.Core (AltCon(..) )+import GHC.Core.Type++import GHC.StgToCmm.Types++import GHC.Stg.Utils+import GHC.Stg.Syntax as StgSyn++import GHC.Data.Maybe+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain++import GHC.Utils.Outputable+import GHC.Utils.Monad.State.Strict+import GHC.Utils.Misc++import GHC.Stg.InferTags.Types++import Control.Monad+import GHC.Types.Basic (CbvMark (NotMarkedCbv, MarkedCbv), isMarkedCbv, TopLevelFlag(..), isTopLevel)+import GHC.Types.Var.Set++-- import GHC.Utils.Trace+-- import GHC.Driver.Ppr++newtype RM a = RM { unRM :: (State (UniqFM Id TagSig, UniqSupply, Module, IdSet) a) }+ deriving (Functor, Monad, Applicative)++------------------------------------------------------------+-- Add cases around strict fields where required.+------------------------------------------------------------+{-+The work of this pass is simple:+* We traverse the STG AST looking for constructor allocations.+* For all allocations we check if there are strict fields in the constructor.+* For any strict field we check if the argument is known to be properly tagged.+* If it's not known to be properly tagged, we wrap the whole thing in a case,+ which will force the argument before allocation.+This is described in detail in Note [Strict Field Invariant].++The only slight complication is that we have to make sure not to invalidate free+variable analysis in the process.++Note [Partially applied workers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Sometimes we will get a function f of the form+ -- Arity 1+ f :: Dict a -> a -> b -> (c -> d)+ f dict a b = case dict of+ C m1 m2 -> m1 a b++Which will result in a W/W split along the lines of+ -- Arity 1+ f :: Dict a -> a -> b -> (c -> d)+ f dict a = case dict of+ C m1 m2 -> $wf m1 a b++ -- Arity 4+ $wf :: (a -> b -> d -> c) -> a -> b -> c -> d+ $wf m1 a b c = m1 a b c++It's notable that the worker is called *undersatured* in the wrapper.+At runtime what happens is that the wrapper will allocate a PAP which+once fully applied will call the worker. And all is fine.++But what about a strict worker! Well the function returned by `f` would+be a unknown call, so we lose the ability to enfore the invariant that+cbv marked arguments from StictWorkerId's are actually properly tagged+as the annotations would be unavailable at the (unknown) call site.++The fix is easy. We eta-expand all calls to functions taking call-by-value+arguments during CorePrep just like we do with constructor allocations.++Note [Upholding free variable annotations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The code generator requires us to maintain exact information+about free variables about closures. Since we convert some+RHSs from constructor allocations to closures we have to provide+fvs of these closures. Not all constructor arguments will become+free variables. Only these which are not bound at the top level+have to be captured.+To facilitate this we keep track of a set of locally bound variables in+the current context which we then use to filter constructor arguments+when building the free variable list.+-}++--------------------------------+-- Utilities+--------------------------------++instance MonadUnique RM where+ getUniqueSupplyM = RM $ do+ (m, us, mod,lcls) <- get+ let (us1, us2) = splitUniqSupply us+ (put) (m,us2,mod,lcls)+ return us1++getMap :: RM (UniqFM Id TagSig)+getMap = RM $ ((\(fst,_,_,_) -> fst) <$> get)++setMap :: (UniqFM Id TagSig) -> RM ()+setMap m = RM $ do+ (_,us,mod,lcls) <- get+ put (m, us,mod,lcls)++getMod :: RM Module+getMod = RM $ ( (\(_,_,thrd,_) -> thrd) <$> get)++getFVs :: RM IdSet+getFVs = RM $ ((\(_,_,_,lcls) -> lcls) <$> get)++setFVs :: IdSet -> RM ()+setFVs fvs = RM $ do+ (tag_map,us,mod,_lcls) <- get+ put (tag_map, us,mod,fvs)++-- Rewrite the RHS(s) while making the id and it's sig available+-- to determine if things are tagged/need to be captured as FV.+withBind :: TopLevelFlag -> GenStgBinding 'InferTaggedBinders -> RM a -> RM a+withBind top_flag (StgNonRec bnd _) cont = withBinder top_flag bnd cont+withBind top_flag (StgRec binds) cont = do+ let (bnds,_rhss) = unzip binds :: ([(Id, TagSig)], [GenStgRhs 'InferTaggedBinders])+ withBinders top_flag bnds cont++addTopBind :: GenStgBinding 'InferTaggedBinders -> RM ()+addTopBind (StgNonRec (id, tag) _) = do+ s <- getMap+ -- pprTraceM "AddBind" (ppr id)+ setMap $ addToUFM s id tag+ return ()+addTopBind (StgRec binds) = do+ let (bnds,_rhss) = unzip binds+ !s <- getMap+ -- pprTraceM "AddBinds" (ppr $ map fst bnds)+ setMap $! addListToUFM s bnds++withBinder :: TopLevelFlag -> (Id, TagSig) -> RM a -> RM a+withBinder top_flag (id,sig) cont = do+ oldMap <- getMap+ setMap $ addToUFM oldMap id sig+ a <- if isTopLevel top_flag+ then cont+ else withLcl id cont+ setMap oldMap+ return a++withBinders :: TopLevelFlag -> [(Id, TagSig)] -> RM a -> RM a+withBinders TopLevel sigs cont = do+ oldMap <- getMap+ setMap $ addListToUFM oldMap sigs+ a <- cont+ setMap oldMap+ return a+withBinders NotTopLevel sigs cont = do+ oldMap <- getMap+ oldFvs <- getFVs+ setMap $ addListToUFM oldMap sigs+ setFVs $ extendVarSetList oldFvs (map fst sigs)+ a <- cont+ setMap oldMap+ setFVs oldFvs+ return a++-- | Compute the argument with the given set of ids treated as requiring capture+-- as free variables.+withClosureLcls :: DIdSet -> RM a -> RM a+withClosureLcls fvs act = do+ old_fvs <- getFVs+ let fvs' = nonDetStrictFoldDVarSet (flip extendVarSet) old_fvs fvs+ setFVs fvs'+ r <- act+ setFVs old_fvs+ return r++-- | Compute the argument with the given id treated as requiring capture+-- as free variables in closures.+withLcl :: Id -> RM a -> RM a+withLcl fv act = do+ old_fvs <- getFVs+ let fvs' = extendVarSet old_fvs fv+ setFVs fvs'+ r <- act+ setFVs old_fvs+ return r++isTagged :: Id -> RM Bool+isTagged v = do+ this_mod <- getMod+ case nameIsLocalOrFrom this_mod (idName v) of+ True+ | isUnliftedType (idType v)+ -> return True+ | otherwise -> do -- Local binding+ !s <- getMap+ let !sig = lookupWithDefaultUFM s (pprPanic "unknown Id:" (ppr v)) v+ return $ case sig of+ TagSig info ->+ case info of+ TagDunno -> False+ TagProper -> True+ TagTagged -> True+ TagTuple _ -> True -- Consider unboxed tuples tagged.+ False -- Imported+ | Just con <- (isDataConWorkId_maybe v)+ , isNullaryRepDataCon con+ -> return True+ | Just lf_info <- idLFInfo_maybe v+ -> return $+ -- Can we treat the thing as tagged based on it's LFInfo?+ case lf_info of+ -- Function, applied not entered.+ LFReEntrant {}+ -> True+ -- Thunks need to be entered.+ LFThunk {}+ -> False+ -- LFCon means we already know the tag, and it's tagged.+ LFCon {}+ -> True+ LFUnknown {}+ -> False+ LFUnlifted {}+ -> True+ LFLetNoEscape {}+ -- Shouldn't be possible. I don't think we can export letNoEscapes+ -> True++ | otherwise+ -> return False+++isArgTagged :: StgArg -> RM Bool+isArgTagged (StgLitArg _) = return True+isArgTagged (StgVarArg v) = isTagged v++mkLocalArgId :: Id -> RM Id+mkLocalArgId id = do+ !u <- getUniqueM+ return $! setIdUnique (localiseId id) u++---------------------------+-- Actual rewrite pass+---------------------------+++rewriteTopBinds :: Module -> UniqSupply -> [GenStgTopBinding 'InferTaggedBinders] -> [TgStgTopBinding]+rewriteTopBinds mod us binds =+ let doBinds = mapM rewriteTop binds++ in evalState (unRM doBinds) (mempty, us, mod, mempty)++rewriteTop :: InferStgTopBinding -> RM TgStgTopBinding+rewriteTop (StgTopStringLit v s) = return $! (StgTopStringLit v s)+rewriteTop (StgTopLifted bind) = do+ -- Top level bindings can, and must remain in scope+ addTopBind bind+ (StgTopLifted) <$!> (rewriteBinds TopLevel bind)++-- For top level binds, the wrapper is guaranteed to be `id`+rewriteBinds :: TopLevelFlag -> InferStgBinding -> RM (TgStgBinding)+rewriteBinds _top_flag (StgNonRec v rhs) = do+ (!rhs) <- rewriteRhs v rhs+ return $! (StgNonRec (fst v) rhs)+rewriteBinds top_flag b@(StgRec binds) =+ -- Bring sigs of binds into scope for all rhss+ withBind top_flag b $ do+ (rhss) <- mapM (uncurry rewriteRhs) binds+ return $! (mkRec rhss)+ where+ mkRec :: [TgStgRhs] -> TgStgBinding+ mkRec rhss = StgRec (zip (map (fst . fst) binds) rhss)++-- Rewrite a RHS+rewriteRhs :: (Id,TagSig) -> InferStgRhs+ -> RM (TgStgRhs)+rewriteRhs (_id, _tagSig) (StgRhsCon ccs con cn ticks args) = {-# SCC rewriteRhs_ #-} do+ -- pprTraceM "rewriteRhs" (ppr _id)++ -- Look up the nodes representing the constructor arguments.+ fieldInfos <- mapM isArgTagged args++ -- Filter out non-strict fields.+ let strictFields =+ getStrictConArgs con (zip args fieldInfos) :: [(StgArg,Bool)] -- (nth-argument, tagInfo)+ -- Filter out already tagged arguments.+ let needsEval = map fst . --get the actual argument+ filter (not . snd) $ -- Keep untagged (False) elements.+ strictFields :: [StgArg]+ let evalArgs = [v | StgVarArg v <- needsEval] :: [Id]++ if (null evalArgs)+ then return $! (StgRhsCon ccs con cn ticks args)+ else do+ --assert not (isTaggedSig tagSig)+ -- pprTraceM "CreatingSeqs for " $ ppr _id <+> ppr node_id++ -- At this point iff we have possibly untagged arguments to strict fields+ -- we convert the RHS into a RhsClosure which will evaluate the arguments+ -- before allocating the constructor.+ let ty_stub = panic "mkSeqs shouldn't use the type arg"+ conExpr <- mkSeqs args evalArgs (\taggedArgs -> StgConApp con cn taggedArgs ty_stub)++ fvs <- fvArgs args+ -- lcls <- getFVs+ -- pprTraceM "RhsClosureConversion" (ppr (StgRhsClosure fvs ccs ReEntrant [] $! conExpr) $$ text "lcls:" <> ppr lcls)+ return $! (StgRhsClosure fvs ccs ReEntrant [] $! conExpr)+rewriteRhs _binding (StgRhsClosure fvs ccs flag args body) = do+ withBinders NotTopLevel args $+ withClosureLcls fvs $+ StgRhsClosure fvs ccs flag (map fst args) <$> rewriteExpr False body+ -- return (closure)++fvArgs :: [StgArg] -> RM DVarSet+fvArgs args = do+ fv_lcls <- getFVs+ -- pprTraceM "fvArgs" (text "args:" <> ppr args $$ text "lcls:" <> pprVarSet (fv_lcls) (braces . fsep . map ppr) )+ return $ mkDVarSet [ v | StgVarArg v <- args, elemVarSet v fv_lcls]++type IsScrut = Bool++rewriteExpr :: IsScrut -> InferStgExpr -> RM TgStgExpr+rewriteExpr _ (e@StgCase {}) = rewriteCase e+rewriteExpr _ (e@StgLet {}) = rewriteLet e+rewriteExpr _ (e@StgLetNoEscape {}) = rewriteLetNoEscape e+rewriteExpr isScrut (StgTick t e) = StgTick t <$!> rewriteExpr isScrut e+rewriteExpr _ e@(StgConApp {}) = rewriteConApp e++rewriteExpr isScrut e@(StgApp {}) = rewriteApp isScrut e+rewriteExpr _ (StgLit lit) = return $! (StgLit lit)+rewriteExpr _ (StgOpApp op args res_ty) = return $! (StgOpApp op args res_ty)++rewriteCase :: InferStgExpr -> RM TgStgExpr+rewriteCase (StgCase scrut bndr alt_type alts) =+ withBinder NotTopLevel bndr $+ pure StgCase <*>+ rewriteExpr True scrut <*>+ pure (fst bndr) <*>+ pure alt_type <*>+ mapM rewriteAlt alts++rewriteCase _ = panic "Impossible: nodeCase"++rewriteAlt :: InferStgAlt -> RM TgStgAlt+rewriteAlt (altCon, bndrs, rhs) = do+ withBinders NotTopLevel bndrs $ do+ !rhs' <- rewriteExpr False rhs+ return $! (altCon, map fst bndrs, rhs')++rewriteLet :: InferStgExpr -> RM TgStgExpr+rewriteLet (StgLet xt bind expr) = do+ (!bind') <- rewriteBinds NotTopLevel bind+ withBind NotTopLevel bind $ do+ -- pprTraceM "withBindLet" (ppr $ bindersOfX bind)+ !expr' <- rewriteExpr False expr+ return $! (StgLet xt bind' expr')+rewriteLet _ = panic "Impossible"++rewriteLetNoEscape :: InferStgExpr -> RM TgStgExpr+rewriteLetNoEscape (StgLetNoEscape xt bind expr) = do+ (!bind') <- rewriteBinds NotTopLevel bind+ withBind NotTopLevel bind $ do+ !expr' <- rewriteExpr False expr+ return $! (StgLetNoEscape xt bind' expr')+rewriteLetNoEscape _ = panic "Impossible"++rewriteConApp :: InferStgExpr -> RM TgStgExpr+rewriteConApp (StgConApp con cn args tys) = do+ -- We check if the strict field arguments are already known to be tagged.+ -- If not we evaluate them first.+ fieldInfos <- mapM isArgTagged args+ let strictIndices = getStrictConArgs con (zip fieldInfos args) :: [(Bool, StgArg)]+ let needsEval = map snd . filter (not . fst) $ strictIndices :: [StgArg]+ let evalArgs = [v | StgVarArg v <- needsEval] :: [Id]+ if (not $ null evalArgs)+ then do+ -- pprTraceM "Creating conAppSeqs for " $ ppr nodeId <+> parens ( ppr evalArgs ) -- <+> parens ( ppr fieldInfos )+ mkSeqs args evalArgs (\taggedArgs -> StgConApp con cn taggedArgs tys)+ else return $! (StgConApp con cn args tys)++rewriteConApp _ = panic "Impossible"++-- Special case: Expressions like `case x of { ... }`+rewriteApp :: IsScrut -> InferStgExpr -> RM TgStgExpr+rewriteApp True (StgApp f []) = do+ -- pprTraceM "rewriteAppScrut" (ppr f)+ f_tagged <- isTagged f+ -- isTagged looks at more than the result of our analysis.+ -- So always update here if useful.+ let f' = if f_tagged+ then setIdTagSig f (TagSig TagProper)+ else f+ return $! StgApp f' []+rewriteApp _ (StgApp f args)+ -- | pprTrace "rewriteAppOther" (ppr f <+> ppr args) False+ -- = undefined+ | Just marks <- idCbvMarks_maybe f+ , relevant_marks <- dropWhileEndLE (not . isMarkedCbv) marks+ , any isMarkedCbv relevant_marks+ = assert (length relevant_marks <= length args)+ unliftArg relevant_marks++ where+ -- If the function expects any argument to be call-by-value ensure the argument is already+ -- evaluated.+ unliftArg relevant_marks = do+ argTags <- mapM isArgTagged args+ let argInfo = zipWith3 ((,,)) args (relevant_marks++repeat NotMarkedCbv) argTags :: [(StgArg, CbvMark, Bool)]++ -- untagged cbv argument positions+ cbvArgInfo = filter (\x -> sndOf3 x == MarkedCbv && thdOf3 x == False) argInfo+ cbvArgIds = [x | StgVarArg x <- map fstOf3 cbvArgInfo] :: [Id]+ mkSeqs args cbvArgIds (\cbv_args -> StgApp f cbv_args)++rewriteApp _ (StgApp f args) = return $ StgApp f args+rewriteApp _ _ = panic "Impossible"++-- `mkSeq` x x' e generates `case x of x' -> e`+-- We could also substitute x' for x in e but that's so rarely beneficial+-- that we don't bother.+mkSeq :: Id -> Id -> TgStgExpr -> TgStgExpr+mkSeq id bndr !expr =+ -- pprTrace "mkSeq" (ppr (id,bndr)) $+ let altTy = mkStgAltTypeFromStgAlts bndr [(DEFAULT, [], panic "Not used")]+ in+ StgCase (StgApp id []) bndr altTy [(DEFAULT, [], expr)]++-- `mkSeqs args vs mkExpr` will force all vs, and construct+-- an argument list args' where each v is replaced by it's evaluated+-- counterpart v'.+-- That is if we call `mkSeqs [StgVar x, StgLit l] [x] mkExpr` then+-- the result will be (case x of x' { _DEFAULT -> <mkExpr [StgVar x', StgLit l]>}+{-# INLINE mkSeqs #-} -- We inline to avoid allocating mkExpr+mkSeqs :: [StgArg] -- ^ Original arguments+ -> [Id] -- ^ var args to be evaluated ahead of time+ -> ([StgArg] -> TgStgExpr)+ -- ^ Function that reconstructs the expressions when passed+ -- the list of evaluated arguments.+ -> RM TgStgExpr+mkSeqs args untaggedIds mkExpr = do+ argMap <- mapM (\arg -> (arg,) <$> mkLocalArgId arg ) untaggedIds :: RM [(InId, OutId)]+ -- mapM_ (pprTraceM "Forcing strict args before allocation:" . ppr) argMap+ let taggedArgs :: [StgArg]+ = map (\v -> case v of+ StgVarArg v' -> StgVarArg $ fromMaybe v' $ lookup v' argMap+ lit -> lit)+ args++ let conBody = mkExpr taggedArgs+ let body = foldr (\(v,bndr) expr -> mkSeq v bndr expr) conBody argMap+ return $! body++-- Out of all arguments passed at runtime only return these ending up in a+-- strict field+getStrictConArgs :: DataCon -> [a] -> [a]+getStrictConArgs con args+ -- These are always lazy in their arguments.+ | isUnboxedTupleDataCon con = []+ | isUnboxedSumDataCon con = []+ -- For proper data cons we have to check.+ | otherwise =+ [ arg | (arg,MarkedStrict)+ <- zipEqual "getStrictConArgs"+ args+ (dataConRuntimeRepStrictness con)]
+ compiler/GHC/Stg/InferTags/Types.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}++{-# LANGUAGE UndecidableInstances #-}+ -- To permit: type instance XLet 'InferTaggedBinders = XLet 'CodeGen++module GHC.Stg.InferTags.Types+ ( module GHC.Stg.InferTags.Types+ , module TagSig)+where++import GHC.Prelude++import GHC.Core.DataCon+import GHC.Core.Type (isUnliftedType)+import GHC.Types.Id+import GHC.Stg.Syntax+import GHC.Stg.InferTags.TagSig as TagSig+import GHC.Types.Var.Env+import GHC.Utils.Outputable+import GHC.Utils.Misc( zipWithEqual )+import GHC.Utils.Panic++import GHC.StgToCmm.Types++{- *********************************************************************+* *+ Supporting data types+* *+********************************************************************* -}++type instance BinderP 'InferTaggedBinders = (Id, TagSig)+type instance XLet 'InferTaggedBinders = XLet 'CodeGen+type instance XLetNoEscape 'InferTaggedBinders = XLetNoEscape 'CodeGen+type instance XRhsClosure 'InferTaggedBinders = XRhsClosure 'CodeGen++type InferStgTopBinding = GenStgTopBinding 'InferTaggedBinders+type InferStgBinding = GenStgBinding 'InferTaggedBinders+type InferStgExpr = GenStgExpr 'InferTaggedBinders+type InferStgRhs = GenStgRhs 'InferTaggedBinders+type InferStgAlt = GenStgAlt 'InferTaggedBinders++combineAltInfo :: TagInfo -> TagInfo -> TagInfo+combineAltInfo TagDunno _ = TagDunno+combineAltInfo _ TagDunno = TagDunno+combineAltInfo (TagTuple {}) TagProper = panic "Combining unboxed tuple with non-tuple result"+combineAltInfo TagProper (TagTuple {}) = panic "Combining unboxed tuple with non-tuple result"+combineAltInfo TagProper TagProper = TagProper+combineAltInfo (TagTuple is1) (TagTuple is2) = TagTuple (zipWithEqual "combineAltInfo" combineAltInfo is1 is2)+combineAltInfo (TagTagged) ti = ti+combineAltInfo ti TagTagged = ti++type TagSigEnv = IdEnv TagSig+data TagEnv p = TE { te_env :: TagSigEnv+ , te_get :: BinderP p -> Id+ }++instance Outputable (TagEnv p) where+ ppr te = ppr (te_env te)+++getBinderId :: TagEnv p -> BinderP p -> Id+getBinderId = te_get++initEnv :: TagEnv 'CodeGen+initEnv = TE { te_env = emptyVarEnv+ , te_get = \x -> x}++-- | Simple convert env to a env of the 'InferTaggedBinders pass+-- with no other changes.+makeTagged :: TagEnv p -> TagEnv 'InferTaggedBinders+makeTagged env = TE { te_env = te_env env+ , te_get = fst }++noSig :: TagEnv p -> BinderP p -> (Id, TagSig)+noSig env bndr+ | isUnliftedType (idType var) = (var, TagSig TagProper)+ | otherwise = (var, TagSig TagDunno)+ where+ var = getBinderId env bndr++lookupSig :: TagEnv p -> Id -> Maybe TagSig+lookupSig env fun = lookupVarEnv (te_env env) fun++lookupInfo :: TagEnv p -> StgArg -> TagInfo+lookupInfo env (StgVarArg var)+ -- Nullary data constructors like True, False+ | Just dc <- isDataConWorkId_maybe var+ , isNullaryRepDataCon dc+ = TagProper++ | isUnliftedType (idType var)+ = TagProper++ -- Variables in the environment.+ | Just (TagSig info) <- lookupVarEnv (te_env env) var+ = info++ | Just lf_info <- idLFInfo_maybe var+ = case lf_info of+ -- Function, tagged (with arity)+ LFReEntrant {}+ -> TagProper+ -- Thunks need to be entered.+ LFThunk {}+ -> TagDunno+ -- Constructors, already tagged.+ LFCon {}+ -> TagProper+ LFUnknown {}+ -> TagDunno+ LFUnlifted {}+ -> TagProper+ -- Shouldn't be possible. I don't think we can export letNoEscapes+ LFLetNoEscape {} -> panic "LFLetNoEscape exported"++ | otherwise+ = TagDunno++lookupInfo _ (StgLitArg {})+ = TagProper++isDunnoSig :: TagSig -> Bool+isDunnoSig (TagSig TagDunno) = True+isDunnoSig (TagSig TagProper) = False+isDunnoSig (TagSig TagTuple{}) = False+isDunnoSig (TagSig TagTagged{}) = False++isTaggedInfo :: TagInfo -> Bool+isTaggedInfo TagProper = True+isTaggedInfo TagTagged = True+isTaggedInfo _ = False++extendSigEnv :: TagEnv p -> [(Id,TagSig)] -> TagEnv p+extendSigEnv env@(TE { te_env = sig_env }) bndrs+ = env { te_env = extendVarEnvList sig_env bndrs }
compiler/GHC/Stg/Lift.hs view
@@ -11,6 +11,7 @@ ( -- * Late lambda lifting in STG -- $note+ StgLiftConfig (..), stgLiftLams ) where@@ -18,9 +19,9 @@ import GHC.Prelude import GHC.Types.Basic-import GHC.Driver.Session import GHC.Types.Id import GHC.Stg.FVs ( annBindingFreeVars )+import GHC.Stg.Lift.Config import GHC.Stg.Lift.Analysis import GHC.Stg.Lift.Monad import GHC.Stg.Syntax@@ -125,8 +126,8 @@ -- -- (Mostly) textbook instance of the lambda lifting transformation, selecting -- which bindings to lambda lift by consulting 'goodToLift'.-stgLiftLams :: Module -> DynFlags -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]-stgLiftLams this_mod dflags us = runLiftM dflags us . foldr (liftTopLvl this_mod) (pure ())+stgLiftLams :: Module -> StgLiftConfig -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]+stgLiftLams this_mod cfg us = runLiftM cfg us . foldr (liftTopLvl this_mod) (pure ()) liftTopLvl :: Module -> InStgTopBinding -> LiftM () -> LiftM () liftTopLvl _ (StgTopStringLit bndr lit) rest = withSubstBndr bndr $ \bndr' -> do@@ -168,8 +169,8 @@ let (infos, rhss) = unzip pairs let bndrs = map binderInfoBndr infos expander <- liftedIdsExpander- dflags <- getDynFlags- case goodToLift dflags top rec expander pairs scope of+ cfg <- getConfig+ case goodToLift cfg top rec expander pairs scope of -- @abs_ids@ is the set of all variables that need to become parameters. Just abs_ids -> withLiftedBndrs abs_ids bndrs $ \bndrs' -> do -- Within this block, all binders in @bndrs@ will be noted as lifted, so
compiler/GHC/Stg/Lift/Analysis.hs view
@@ -26,9 +26,9 @@ import GHC.Types.Basic import GHC.Types.Demand-import GHC.Driver.Session import GHC.Types.Id import GHC.Runtime.Heap.Layout ( WordOff )+import GHC.Stg.Lift.Config import GHC.Stg.Syntax import qualified GHC.StgToCmm.ArgRep as StgToCmm.ArgRep import qualified GHC.StgToCmm.Closure as StgToCmm.Closure@@ -342,7 +342,7 @@ -- | Combines several heuristics to decide whether to lambda-lift a given -- @let@-binding to top-level. See "GHC.Stg.Lift.Analysis#when" for details. goodToLift- :: DynFlags+ :: StgLiftConfig -> TopLevelFlag -> RecFlag -> (DIdSet -> DIdSet) -- ^ An expander function, turning 'InId's into@@ -352,7 +352,7 @@ -> Maybe DIdSet -- ^ @Just abs_ids@ <=> This binding is beneficial to -- lift and @abs_ids@ are the variables it would -- abstract over-goodToLift dflags top_lvl rec_flag expander pairs scope = decide+goodToLift cfg top_lvl rec_flag expander pairs scope = decide [ ("top-level", isTopLevel top_lvl) -- keep in sync with Note [When to lift] , ("memoized", any_memoized) , ("argument occurrences", arg_occs)@@ -362,7 +362,7 @@ , ("args spill on stack", args_spill_on_stack) , ("increases allocation", inc_allocs) ] where- profile = targetProfile dflags+ profile = c_targetProfile cfg platform = profilePlatform profile decide deciders | not (fancy_or deciders)@@ -431,7 +431,7 @@ -- idArity f > 0 ==> known known_fun id = idArity id > 0 abstracts_known_local_fun- = not (liftLamsKnown dflags) && any known_fun (dVarSetElems abs_ids)+ = not (c_liftLamsKnown cfg) && any known_fun (dVarSetElems abs_ids) -- Number of arguments of a RHS in the current binding group if we decide -- to lift it@@ -441,8 +441,8 @@ . (dVarSetElems abs_ids ++) . rhsLambdaBndrs max_n_args- | isRec rec_flag = liftLamsRecArgs dflags- | otherwise = liftLamsNonRecArgs dflags+ | isRec rec_flag = c_liftLamsRecArgs cfg+ | otherwise = c_liftLamsNonRecArgs cfg -- We have 5 hardware registers on x86_64 to pass arguments in. Any excess -- args are passed on the stack, which means slow memory accesses args_spill_on_stack
+ compiler/GHC/Stg/Lift/Config.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE TypeFamilies #-}++-- | Configuration options for Lift the lambda lifter.+module GHC.Stg.Lift.Config (+ StgLiftConfig (..),+ ) where++import GHC.Prelude++import GHC.Platform.Profile++data StgLiftConfig = StgLiftConfig+ { c_targetProfile :: !Profile+ , c_liftLamsRecArgs :: !(Maybe Int)+ -- ^ Maximum number of arguments after lambda lifting a recursive function.+ , c_liftLamsNonRecArgs :: !(Maybe Int)+ -- ^ Maximum number of arguments after lambda lifting non-recursive function.+ , c_liftLamsKnown :: !Bool+ -- ^ Lambda lift even when this turns a known call into an unknown call.+ }+ deriving (Show, Read, Eq, Ord)
compiler/GHC/Stg/Lift/Monad.hs view
@@ -12,6 +12,8 @@ FloatLang (..), collectFloats, -- Exported just for the docs -- * Transformation monad LiftM, runLiftM,+ -- ** Get config+ getConfig, -- ** Adding bindings startBindingGroup, endBindingGroup, addTopStringLit, addLiftedBinding, -- ** Substitution and binders@@ -24,14 +26,16 @@ import GHC.Types.Basic import GHC.Types.CostCentre ( isCurrentCCS, dontCareCCS )-import GHC.Driver.Session import GHC.Data.FastString import GHC.Types.Id import GHC.Types.Name import GHC.Utils.Outputable import GHC.Data.OrdList++import GHC.Stg.Lift.Config import GHC.Stg.Subst import GHC.Stg.Syntax+ import GHC.Core.Utils import GHC.Types.Unique.Supply import GHC.Utils.Panic@@ -59,7 +63,7 @@ -- | Environment threaded around in a scoped, @Reader@-like fashion. data Env = Env- { e_dflags :: !DynFlags+ { e_config :: StgLiftConfig -- ^ Read-only. , e_subst :: !Subst -- ^ We need to track the renamings of local 'InId's to their lifted 'OutId',@@ -82,8 +86,12 @@ -- Invariant: 'Id's not present in this map won't be substituted. } -emptyEnv :: DynFlags -> Env-emptyEnv dflags = Env dflags emptySubst emptyVarEnv+emptyEnv :: StgLiftConfig -> Env+emptyEnv cfg = Env+ { e_config = cfg+ , e_subst = emptySubst+ , e_expansions = emptyVarEnv+ } -- Note [Handling floats]@@ -200,8 +208,8 @@ -- | The analysis monad consists of the following 'RWST' components: -- -- * 'Env': Reader-like context. Contains a substitution, info about how--- how lifted identifiers are to be expanded into applications and details--- such as 'DynFlags'.+-- how lifted identifiers are to be expanded into applications and+-- configuration options. -- -- * @'OrdList' 'FloatLang'@: Writer output for the resulting STG program. --@@ -214,18 +222,18 @@ = LiftM { unwrapLiftM :: RWST Env (OrdList FloatLang) () UniqSM a } deriving (Functor, Applicative, Monad) -instance HasDynFlags LiftM where- getDynFlags = LiftM (RWS.asks e_dflags)- instance MonadUnique LiftM where getUniqueSupplyM = LiftM (lift getUniqueSupplyM) getUniqueM = LiftM (lift getUniqueM) getUniquesM = LiftM (lift getUniquesM) -runLiftM :: DynFlags -> UniqSupply -> LiftM () -> [OutStgTopBinding]-runLiftM dflags us (LiftM m) = collectFloats (fromOL floats)+runLiftM :: StgLiftConfig -> UniqSupply -> LiftM () -> [OutStgTopBinding]+runLiftM cfg us (LiftM m) = collectFloats (fromOL floats) where- (_, _, floats) = initUs_ us (runRWST m (emptyEnv dflags) ())+ (_, _, floats) = initUs_ us (runRWST m (emptyEnv cfg) ())++getConfig :: LiftM StgLiftConfig+getConfig = LiftM $ e_config <$> RWS.ask -- | Writes a plain 'StgTopStringLit' to the output. addTopStringLit :: OutId -> ByteString -> LiftM ()
compiler/GHC/Stg/Lint.hs view
@@ -40,9 +40,7 @@ import GHC.Prelude import GHC.Stg.Syntax--import GHC.Driver.Session-import GHC.Driver.Config.Diagnostic+import GHC.Stg.Utils import GHC.Core.Lint ( interactiveInScope ) import GHC.Core.DataCon@@ -51,6 +49,7 @@ import GHC.Types.Basic ( TopLevelFlag(..), isTopLevel ) import GHC.Types.CostCentre ( isCurrentCCS )+import GHC.Types.Error ( DiagnosticReason(WarningWithoutFlag) ) import GHC.Types.Id import GHC.Types.Var.Set import GHC.Types.Name ( getSrcLoc, nameIsLocalOrFrom )@@ -69,10 +68,12 @@ import Control.Applicative ((<|>)) import Control.Monad+import Data.Maybe lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id) => Logger- -> DynFlags+ -> DiagOpts+ -> StgPprOpts -> InteractiveContext -> Module -- ^ module being compiled -> Bool -- ^ have we run Unarise yet?@@ -80,7 +81,7 @@ -> [GenStgTopBinding a] -> IO () -lintStgTopBindings logger dflags ictxt this_mod unarised whodunnit binds+lintStgTopBindings logger diag_opts opts ictxt this_mod unarised whodunnit binds = {-# SCC "StgLint" #-} case initL diag_opts this_mod unarised opts top_level_binds (lint_binds binds) of Nothing ->@@ -96,8 +97,6 @@ text "*** End of Offense ***"]) Err.ghcExit logger 1 where- diag_opts = initDiagOpts dflags- opts = initStgPprOpts dflags -- Bring all top-level binds into scope because CoreToStg does not generate -- bindings in dependency order (so we may see a use before its definition). top_level_binds = extendVarSetList (mkVarSet (bindersOfTopBinds binds))@@ -191,9 +190,23 @@ lintStgExpr (StgLit _) = return () -lintStgExpr (StgApp fun args) = do+lintStgExpr e@(StgApp fun args) = do lintStgVar fun mapM_ lintStgArg args++ lf <- getLintFlags+ when (lf_unarised lf) $ do+ -- A function which expects a unlifted argument as n'th argument+ -- always needs to be applied to n arguments.+ -- See Note [Strict Worker Ids].+ let marks = fromMaybe [] $ idCbvMarks_maybe fun+ if length marks > length args+ then addErrL $ hang (text "Undersatured cbv marked ID in App" <+> ppr e ) 2 $+ (text "marks" <> ppr marks $$+ text "args" <> ppr args $$+ text "arity" <> ppr (idArity fun) $$+ text "join_arity" <> ppr (isJoinId_maybe fun))+ else return () lintStgExpr app@(StgConApp con _n args _arg_tys) = do -- unboxed sums should vanish during unarise
compiler/GHC/Stg/Pipeline.hs view
@@ -9,7 +9,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -module GHC.Stg.Pipeline ( stg2stg ) where+module GHC.Stg.Pipeline+ ( StgPipelineOpts (..)+ , StgToDo (..)+ , stg2stg+ ) where import GHC.Prelude @@ -21,11 +25,11 @@ import GHC.Stg.Unarise ( unarise ) import GHC.Stg.BcPrep ( bcPrep ) import GHC.Stg.CSE ( stgCse )-import GHC.Stg.Lift ( stgLiftLams )+import GHC.Stg.Lift ( StgLiftConfig, stgLiftLams ) import GHC.Unit.Module ( Module ) import GHC.Runtime.Context ( InteractiveContext ) -import GHC.Driver.Session+import GHC.Driver.Flags (DumpFlag(..)) import GHC.Utils.Error import GHC.Types.Unique.Supply import GHC.Utils.Outputable@@ -34,6 +38,14 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Reader +data StgPipelineOpts = StgPipelineOpts+ { stgPipeline_phases :: ![StgToDo]+ -- ^ Spec of what stg-to-stg passes to do+ , stgPipeline_lint :: !(Maybe DiagOpts)+ -- ^ Should we lint the STG at various stages of the pipeline?+ , stgPipeline_pprOpts :: !StgPprOpts+ }+ newtype StgM a = StgM { _unStgM :: ReaderT Char IO a } deriving (Functor, Applicative, Monad, MonadIO) @@ -47,18 +59,17 @@ runStgM mask (StgM m) = runReaderT m mask stg2stg :: Logger- -> DynFlags -- includes spec of what stg-to-stg passes to do -> InteractiveContext- -> Bool -- prepare for bytecode?+ -> StgPipelineOpts -> Module -- module being compiled -> [StgTopBinding] -- input program -> IO [CgStgTopBinding] -- output program-stg2stg logger dflags ictxt for_bytecode this_mod binds+stg2stg logger ictxt opts this_mod binds = do { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds ; showPass logger "Stg2Stg" -- Do the main business! ; binds' <- runStgM 'g' $- foldM (do_stg_pass this_mod) binds (getStgToDo for_bytecode dflags)+ foldM (do_stg_pass this_mod) binds (stgPipeline_phases opts) -- Dependency sort the program as last thing. The program needs to be -- in dependency order for the SRT algorithm to work (see@@ -76,8 +87,11 @@ where stg_linter unarised- | gopt Opt_DoStgLinting dflags- = lintStgTopBindings logger dflags ictxt this_mod unarised+ | Just diag_opts <- stgPipeline_lint opts+ = lintStgTopBindings+ logger+ diag_opts ppr_opts+ ictxt this_mod unarised | otherwise = \ _whodunnit _binds -> return () @@ -95,10 +109,10 @@ let binds' = {-# SCC "StgCse" #-} stgCse binds end_pass "StgCse" binds' - StgLiftLams -> do+ StgLiftLams cfg -> do us <- getUniqueSupplyM --- let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams this_mod dflags us binds+ let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams this_mod cfg us binds end_pass "StgLiftLams" binds' StgBcPrep -> do@@ -114,14 +128,14 @@ liftIO (stg_linter True "Unarise" binds') return binds' - opts = initStgPprOpts dflags+ ppr_opts = stgPipeline_pprOpts opts dump_when flag header binds- = putDumpFileMaybe logger flag header FormatSTG (pprStgTopBindings opts binds)+ = putDumpFileMaybe logger flag header FormatSTG (pprStgTopBindings ppr_opts binds) end_pass what binds2 = liftIO $ do -- report verbosely, if required putDumpFileMaybe logger Opt_D_verbose_stg2stg what- FormatSTG (vcat (map (pprStgTopBinding opts) binds2))+ FormatSTG (vcat (map (pprStgTopBinding ppr_opts) binds2)) stg_linter False what binds2 return binds2 @@ -132,7 +146,7 @@ data StgToDo = StgCSE -- ^ Common subexpression elimination- | StgLiftLams+ | StgLiftLams StgLiftConfig -- ^ Lambda lifting closure variables, trading stack/register allocation for -- heap allocation | StgStats@@ -142,23 +156,4 @@ -- ^ Mandatory when compiling to bytecode | StgDoNothing -- ^ Useful for building up 'getStgToDo'- deriving Eq---- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.-getStgToDo :: Bool -> DynFlags -> [StgToDo]-getStgToDo for_bytecode dflags =- filter (/= StgDoNothing)- [ mandatory StgUnarise- -- Important that unarisation comes first- -- See Note [StgCse after unarisation] in GHC.Stg.CSE- , optional Opt_StgCSE StgCSE- , optional Opt_StgLiftLams StgLiftLams- , runWhen for_bytecode StgBcPrep- , optional Opt_StgStats StgStats- ] where- optional opt = runWhen (gopt opt dflags)- mandatory = id--runWhen :: Bool -> StgToDo -> StgToDo-runWhen True todo = todo-runWhen _ _ = StgDoNothing+ deriving (Show, Read, Eq, Ord)
compiler/GHC/Stg/Stats.hs view
@@ -146,7 +146,7 @@ statExpr (StgApp _ _) = countOne Applications statExpr (StgLit _) = countOne Literals-statExpr (StgConApp _ _ _ _)= countOne ConstructorApps+statExpr (StgConApp {}) = countOne ConstructorApps statExpr (StgOpApp _ _ _) = countOne PrimitiveApps statExpr (StgTick _ e) = statExpr e
compiler/GHC/Stg/Unarise.hs view
@@ -258,6 +258,7 @@ import GHC.Utils.Panic.Plain import GHC.Types.RepType import GHC.Stg.Syntax+import GHC.Stg.Utils import GHC.Core.Type import GHC.Builtin.Types.Prim (intPrimTy) import GHC.Builtin.Types@@ -802,10 +803,10 @@ -------------------------------------------------------------------------------- mkIds :: FastString -> [UnaryType] -> UniqSM [Id]-mkIds fs tys = mapM (mkId fs) tys+mkIds fs tys = mkUnarisedIds fs tys mkId :: FastString -> UnaryType -> UniqSM Id-mkId s t = mkSysLocalM s Many t+mkId s t = mkUnarisedId s t isMultiValBndr :: Id -> Bool isMultiValBndr id
+ compiler/GHC/Stg/Utils.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE CPP, ScopedTypeVariables, TypeFamilies #-}+{-# LANGUAGE DataKinds #-}++module GHC.Stg.Utils+ ( mkStgAltTypeFromStgAlts+ , bindersOf, bindersOfX, bindersOfTop, bindersOfTopBinds++ , stripStgTicksTop, stripStgTicksTopE+ , idArgs++ , mkUnarisedId, mkUnarisedIds+ ) where++import GHC.Prelude++import GHC.Types.Id+import GHC.Core.Type+import GHC.Core.TyCon+import GHC.Core.DataCon+import GHC.Core ( AltCon(..) )+import GHC.Types.Tickish+import GHC.Types.Unique.Supply++import GHC.Types.RepType+import GHC.Stg.Syntax++import GHC.Utils.Outputable++import GHC.Utils.Panic.Plain+import GHC.Utils.Panic++import GHC.Data.FastString++mkUnarisedIds :: MonadUnique m => FastString -> [UnaryType] -> m [Id]+mkUnarisedIds fs tys = mapM (mkUnarisedId fs) tys++mkUnarisedId :: MonadUnique m => FastString -> UnaryType -> m Id+mkUnarisedId s t = mkSysLocalM s Many t++-- Checks if id is a top level error application.+-- isErrorAp_maybe :: Id ->++-- | Extract the default case alternative+-- findDefaultStg :: [Alt b] -> ([Alt b], Maybe (Expr b))+findDefaultStg :: [GenStgAlt p] -> ([(AltCon, [BinderP p], GenStgExpr p)],+ Maybe (GenStgExpr p))+findDefaultStg ((DEFAULT, args, rhs) : alts) = assert( null args ) (alts, Just rhs)+findDefaultStg alts = (alts, Nothing)++mkStgAltTypeFromStgAlts :: forall p. Id -> [GenStgAlt p] -> AltType+mkStgAltTypeFromStgAlts bndr alts+ | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty+ = MultiValAlt (length prim_reps) -- always use MultiValAlt for unboxed tuples++ | otherwise+ = case prim_reps of+ [rep] | isGcPtrRep rep ->+ case tyConAppTyCon_maybe (unwrapType bndr_ty) of+ Just tc+ | isAbstractTyCon tc -> look_for_better_tycon+ | isAlgTyCon tc -> AlgAlt tc+ | otherwise -> assertPpr ( _is_poly_alt_tycon tc) (ppr tc)+ PolyAlt+ Nothing -> PolyAlt+ [non_gcd] -> PrimAlt non_gcd+ not_unary -> MultiValAlt (length not_unary)+ where+ bndr_ty = idType bndr+ prim_reps = typePrimRep bndr_ty++ _is_poly_alt_tycon tc+ = isFunTyCon tc+ || isPrimTyCon tc -- "Any" is lifted but primitive+ || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict+ -- function application where argument has a+ -- type-family type++ -- Sometimes, the TyCon is a AbstractTyCon which may not have any+ -- constructors inside it. Then we may get a better TyCon by+ -- grabbing the one from a constructor alternative+ -- if one exists.+ look_for_better_tycon+ | (((DataAlt con) ,_, _) : _) <- data_alts =+ AlgAlt (dataConTyCon con)+ | otherwise =+ assert(null data_alts)+ PolyAlt+ where+ (data_alts, _deflt) = findDefaultStg alts++bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id]+bindersOf (StgNonRec binder _) = [binder]+bindersOf (StgRec pairs) = [binder | (binder, _) <- pairs]++bindersOfX :: GenStgBinding a -> [BinderP a]+bindersOfX (StgNonRec binder _) = [binder]+bindersOfX (StgRec pairs) = [binder | (binder, _) <- pairs]++bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id]+bindersOfTop (StgTopLifted bind) = bindersOf bind+bindersOfTop (StgTopStringLit binder _) = [binder]++-- All ids we bind something to on the top level.+bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id]+-- bindersOfTopBinds binds = mapUnionVarSet (mkVarSet . bindersOfTop) binds+bindersOfTopBinds binds = foldr ((++) . bindersOfTop) [] binds++idArgs :: [StgArg] -> [Id]+idArgs args = [v | StgVarArg v <- args]++-- | Strip ticks of a given type from an STG expression.+stripStgTicksTop :: (StgTickish -> Bool) -> GenStgExpr p -> ([StgTickish], GenStgExpr p)+stripStgTicksTop p = go []+ where go ts (StgTick t e) | p t = go (t:ts) e+ -- This special case avoid building a thunk for "reverse ts" when there are no ticks+ go [] other = ([], other)+ go ts other = (reverse ts, other)++-- | Strip ticks of a given type from an STG expression returning only the expression.+stripStgTicksTopE :: (StgTickish -> Bool) -> GenStgExpr p -> GenStgExpr p+stripStgTicksTopE p = go+ where go (StgTick t e) | p t = go e+ go other = other
compiler/GHC/StgToByteCode.hs view
@@ -157,7 +157,7 @@ {- Note [generating code for top-level string literal bindings]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is a summary on how the byte code generator deals with top-level string literals: @@ -215,11 +215,11 @@ -> name -> BCInstrList -> Either [CgStgAlt] (CgStgRhs)- -- ^ original expression; for debugging only- -> Int- -> Word16- -> [StgWord]- -> Bool -- True <=> is a return point, rather than a function+ -- ^ original expression; for debugging only+ -> Int -- ^ arity+ -> Word16 -- ^ bitmap size+ -> [StgWord] -- ^ bitmap+ -> Bool -- ^ True <=> is a return point, rather than a function -> [FFIInfo] -> ProtoBCO name mkProtoBCO platform nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis@@ -661,7 +661,7 @@ = unsupportedCConvException -- Case 2: Unboxed tuple-schemeT d s p (StgConApp con _ext args _tys)+schemeT d s p (StgConApp con _cn args _tys) | isUnboxedTupleDataCon con || isUnboxedSumDataCon con = returnUnboxedTuple d s p args @@ -736,10 +736,10 @@ do_pushes init_d args (map (atomRep platform) args) where do_pushes !d [] reps = do- assert (null reps ) return ()+ assert (null reps) return () (push_fn, sz) <- pushAtom d p (StgVarArg fn) platform <- profilePlatform <$> getProfile- assert (sz == wordSize platform ) return ()+ assert (sz == wordSize platform) return () let slide = mkSlideB platform (d - init_d + wordSize platform) (init_d - s) enter = if isUnliftedType (idType fn) then RETURN_UNLIFTED P@@ -784,6 +784,9 @@ = (PUSH_APPLY_D, 1, rest) findPushSeq (L: rest) = (PUSH_APPLY_L, 1, rest)+findPushSeq argReps+ | any (`elem` [V16, V32, V64]) argReps+ = sorry "SIMD vector operations are not available in GHCi" findPushSeq _ = panic "GHC.StgToByteCode.findPushSeq" @@ -817,6 +820,8 @@ (isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) && length non_void_arg_reps > 1 + unlifted_alg_ty = isUnliftedType bndr_ty && isAlgCase+ non_void_arg_reps = non_void (typeArgReps platform bndr_ty) profiling@@ -838,11 +843,12 @@ not ubx_tuple_frame = 2 * wordSize platform | otherwise = 0 - -- An unlifted value gets an extra info table pushed on top- -- when it is returned.+ -- The size of the return frame info table pointer if one exists unlifted_itbl_size_b :: StackDepth- unlifted_itbl_size_b | ubx_tuple_frame = 3 * wordSize platform- | not (isUnliftedType bndr_ty) = 0+ unlifted_itbl_size_b | ubx_tuple_frame = wordSize platform+ | not (isUnliftedType bndr_ty)+ -- See Note [Popping return frame for unlifted things]+ || unlifted_alg_ty = 0 | otherwise = wordSize platform (bndr_size, tuple_info, args_offsets)@@ -877,6 +883,7 @@ isAlgCase = isAlgType bndr_ty -- given an alt, return a discr and code for it.+ codeAlt :: CgStgAlt -> BcM (Discr, BCInstrList) codeAlt (DEFAULT, _, rhs) = do rhs_code <- schemeE d_alts s p_alts rhs return (NoDiscr, rhs_code)@@ -924,16 +931,11 @@ | (NonVoid arg, offset) <- args_offsets ] p_alts - -- unlifted datatypes have an infotable word on top- unpack = if isUnliftedType bndr_ty- then PUSH_L 1 `consOL`- UNPACK (trunc16W size) `consOL`- unitOL (SLIDE (trunc16W size) 1)- else unitOL (UNPACK (trunc16W size)) in do massert isAlgCase rhs_code <- schemeE stack_bot s p' rhs- return (my_discr alt, unpack `appOL` rhs_code)+ return (my_discr alt,+ unitOL (UNPACK (trunc16W size)) `appOL` rhs_code) where real_bndrs = filterOut isTyVar bndrs @@ -1003,7 +1005,23 @@ bitmap = intsToReverseBitmap platform bitmap_size'{-size-} pointers alt_stuff <- mapM codeAlt alts- alt_final <- mkMultiBranch maybe_ncons alt_stuff+ alt_final0 <- mkMultiBranch maybe_ncons alt_stuff+ -- Note [Popping return frame for unlifted things]+ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ -- When an unlifted value is returned, a special stg_ret_XXX_info frame will+ -- be sitting on top of the stack. This mechanism is used to aid in switching+ -- execution contexts between object code and interpreter. However, mkMultiBranch,+ -- which produces the bytecode to discriminate the case alternatives, does not+ -- account for that frame header and does branching based on the top of the stack.+ -- Therefore, we must compensate for this by popping the frame header (2 words+ -- for tuples and 1 word for other unlifted things) before passing control to+ -- the case discrimination continuation. This ensures we are looking at the+ -- right word and it also saves some stack space. Failing to account for this+ -- was the cause of #20194.+ let alt_final+ | ubx_tuple_frame = mkSlideW 0 2 `mappend` alt_final0+ | unlifted_alg_ty = mkSlideW 0 1 `mappend` alt_final0+ | otherwise = alt_final0 let alt_bco_name = getName bndr@@ -1102,7 +1120,6 @@ {- Note [unboxed tuple bytecodes and tuple_BCO] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- We have the bytecode instructions RETURN_TUPLE and PUSH_ALTS_TUPLE to return and receive arbitrary unboxed tuples, respectively. These instructions use the helper data tuple_BCO and tuple_info.@@ -1782,7 +1799,9 @@ | otherwise = return (testEQ (fst val) lbl_default `consOL` snd val) - -- Note [CASEFAIL] It may be that this case has no default+ -- Note [CASEFAIL]+ -- ~~~~~~~~~~~~~~~+ -- It may be that this case has no default -- branch, but the alternatives are not exhaustive - this -- happens for GADT cases for example, where the types -- prove that certain branches are impossible. We could
compiler/GHC/StgToCmm.hs view
@@ -70,6 +70,7 @@ import System.IO.Unsafe import qualified Data.ByteString as BS import Data.IORef+import GHC.Utils.Panic (assertPpr) codeGen :: Logger -> TmpFs@@ -206,7 +207,7 @@ -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise cgTopRhs cfg rec bndr (StgRhsClosure fvs cc upd_flag args body)- = assert (isEmptyDVarSet fvs) -- There should be no free variables+ = assertPpr (isEmptyDVarSet fvs) (text "fvs:" <> ppr fvs) $ -- There should be no free variables cgTopRhsClosure (stgToCmmPlatform cfg) rec bndr cc upd_flag args body @@ -234,8 +235,8 @@ cgEnumerationTyCon :: TyCon -> FCode () cgEnumerationTyCon tycon = do platform <- getPlatform- emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)- [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)+ emitRODataLits (mkClosureTableLabel (tyConName tycon) NoCafRefs)+ [ CmmLabelOff (mkClosureLabel (dataConName con) NoCafRefs) (tagForCon platform con) | con <- tyConDataCons tycon]
compiler/GHC/StgToCmm/ArgRep.hs view
@@ -52,6 +52,7 @@ | V16 -- 16-byte (128-bit) vectors of Float/Double/Int8/Word32/etc. | V32 -- 32-byte (256-bit) vectors of Float/Double/Int8/Word32/etc. | V64 -- 64-byte (512-bit) vectors of Float/Double/Int8/Word32/etc.+ deriving Eq instance Outputable ArgRep where ppr = text . argRepString argRepString :: ArgRep -> String
compiler/GHC/StgToCmm/Bind.hs view
@@ -15,8 +15,6 @@ import GHC.Prelude hiding ((<*>)) -import GHC.Driver.Session- import GHC.Core ( AltCon(..) ) import GHC.Runtime.Heap.Layout import GHC.Unit.Module@@ -34,6 +32,7 @@ import GHC.StgToCmm.Heap import GHC.StgToCmm.Prof (ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk, initUpdFrameProf)+import GHC.StgToCmm.TagCheck import GHC.StgToCmm.Ticky import GHC.StgToCmm.Layout import GHC.StgToCmm.Utils@@ -47,6 +46,7 @@ import GHC.Cmm.Utils import GHC.Cmm.CLabel +import GHC.Stg.Utils import GHC.Types.CostCentre import GHC.Types.Id import GHC.Types.Id.Info@@ -81,7 +81,7 @@ -> (CgIdInfo, FCode ()) cgTopRhsClosure platform rec id ccs upd_flag args body =- let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)+ let closure_label = mkClosureLabel (idName id) (idCafInfo id) cg_id_info = litIdInfo platform id lf_info (CmmLabel closure_label) lf_info = mkClosureLFInfo platform id TopLevel [] upd_flag args in (cg_id_info, gen_code lf_info closure_label)@@ -92,7 +92,7 @@ -- shortcutting the whole process, and generating a lot less code -- (#7308). Eventually the IND_STATIC closure will be eliminated -- by assembly '.equiv' directives, where possible (#15155).- -- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".+ -- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". -- -- Note: we omit the optimisation when this binding is part of a -- recursive group, because the optimisation would inhibit the black@@ -149,7 +149,7 @@ ; emit (catAGraphs inits <*> body) } {- Note [cgBind rec]-+ ~~~~~~~~~~~~~~~~~ Recursive let-bindings are tricky. Consider the following pseudocode: @@ -219,14 +219,19 @@ {- See Note [GC recovery] in "GHC.StgToCmm.Closure" -} cgRhs id (StgRhsClosure fvs cc upd_flag args body)- = do profile <- getProfile- mkRhsClosure profile id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body+ = do+ checkFunctionArgTags (text "TagCheck Failed: Rhs of" <> ppr id) id args+ profile <- getProfile+ check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig+ mkRhsClosure profile check_tags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body + ------------------------------------------------------------------------ -- Non-constructor right hand sides ------------------------------------------------------------------------ -mkRhsClosure :: Profile -> Id -> CostCentreStack+mkRhsClosure :: Profile -> Bool+ -> Id -> CostCentreStack -> [NonVoid Id] -- Free vars -> UpdateFlag -> [Id] -- Args@@ -268,8 +273,8 @@ -} ----------- Note [Selectors] -------------------mkRhsClosure profile bndr _cc+---------- See Note [Selectors] ------------------+mkRhsClosure profile _check_tags bndr _cc [NonVoid the_fv] -- Just one free var upd_flag -- Updatable thunk [] -- A thunk@@ -301,8 +306,8 @@ let lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag) in cgRhsStdThunk bndr lf_info [StgVarArg the_fv] ----------- Note [Ap thunks] -------------------mkRhsClosure profile bndr _cc+---------- See Note [Ap thunks] ------------------+mkRhsClosure profile check_tags bndr _cc fvs upd_flag [] -- No args; a thunk@@ -323,8 +328,8 @@ -- lose information about this particular -- thunk (e.g. its type) (#949) , idArity fun_id == unknownArity -- don't spoil a known call- -- Ha! an Ap thunk+ , not check_tags -- See Note [Tag inference debugging] = cgRhsStdThunk bndr lf_info payload where@@ -335,7 +340,7 @@ payload = StgVarArg fun_id : args ---------- Default case -------------------mkRhsClosure profile bndr cc fvs upd_flag args body+mkRhsClosure profile _check_tags bndr cc fvs upd_flag args body = do { let lf_info = mkClosureLFInfo (profilePlatform profile) bndr NotTopLevel fvs upd_flag args ; (id_info, reg) <- rhsIdInfo bndr lf_info ; return (id_info, gen_code lf_info reg) }@@ -519,6 +524,7 @@ -- Load free vars out of closure *after* -- heap check, to reduce live vars over check ; when node_points $ load_fvs node lf_info fv_bindings+ ; checkFunctionArgTags (text "TagCheck failed - Argument to local function:" <> ppr bndr) bndr (map fromNonVoid nv_args) ; void $ cgExpr body }}} @@ -526,7 +532,6 @@ -- Note [NodeReg clobbered with loopification] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- Previously we used to pass nodeReg (aka R1) here. With profiling, upon -- entering a closure, enterFunCCS was called with R1 passed to it. But since R1 -- may get clobbered inside the body of a closure, and since a self-recursive
compiler/GHC/StgToCmm/CgUtils.hs view
@@ -152,7 +152,7 @@ let baseAddr = get_GlobalReg_addr platform reg in case reg `elem` activeStgRegs platform of True -> CmmAssign (CmmGlobal reg) src- False -> CmmStore baseAddr src+ False -> CmmStore baseAddr src NaturallyAligned other_stmt -> other_stmt fixExpr expr = case expr of@@ -171,7 +171,7 @@ let baseAddr = get_GlobalReg_addr platform reg in case reg of BaseReg -> baseAddr- _other -> CmmLoad baseAddr (globalRegType platform reg)+ _other -> CmmLoad baseAddr (globalRegType platform reg) NaturallyAligned CmmRegOff (CmmGlobal reg) offset -> -- RegOf leaves are just a shorthand form. If the reg maps
compiler/GHC/StgToCmm/Closure.hs view
@@ -4,7 +4,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} - ----------------------------------------------------------------------------- -- -- Stg to C-- code generation:@@ -101,6 +100,7 @@ import Data.Coerce (coerce) import qualified Data.ByteString.Char8 as BS8 import GHC.StgToCmm.Config+import GHC.Stg.InferTags.TagSig (isTaggedSig) ----------------------------------------------------------------------------- -- Data types and synonyms@@ -478,20 +478,38 @@ (rather than directly) to catch double-entry. -} data CallMethod- = EnterIt -- No args, not a function+ = EnterIt -- ^ No args, not a function | JumpToIt BlockId [LocalReg] -- A join point or a header of a local loop | ReturnIt -- It's a value (function, unboxed value, -- or constructor), so just return it. - | SlowCall -- Unknown fun, or known fun with+ | InferedReturnIt -- A properly tagged value, as determined by tag inference.+ -- See Note [Tag Inference] and Note [Tag inference passes] in+ -- GHC.Stg.InferTags.+ -- It behaves /precisely/ like `ReturnIt`, except that when debugging is+ -- enabled we emit an extra assertion to check that the returned value is+ -- properly tagged. We can use this as a check that tag inference is working+ -- correctly.+ -- TODO: SPJ suggested we could combine this with EnterIt, but for now I decided+ -- not to do so.++ | SlowCall -- Unknown fun, or known fun with -- too few args. | DirectEntry -- Jump directly, with args in regs CLabel -- The code label RepArity -- Its arity +instance Outputable CallMethod where+ ppr (EnterIt) = text "Enter"+ ppr (JumpToIt {}) = text "JumpToIt"+ ppr (ReturnIt ) = text "ReturnIt"+ ppr (InferedReturnIt) = text "InferedReturnIt"+ ppr (SlowCall ) = text "SlowCall"+ ppr (DirectEntry {}) = text "DirectEntry"+ getCallMethod :: StgToCmmConfig -> Name -- Function being applied -> Id -- Function Id used to chech if it can refer to@@ -538,6 +556,12 @@ getCallMethod cfg name id (LFThunk _ _ updatable std_form_info is_fun) n_args _v_args _cg_loc _self_loop_info++ | Just sig <- idTagSig_maybe id+ , isTaggedSig sig -- Infered to be already evaluated by Tag Inference+ , n_args == 0 -- See Note [Tag Inference]+ = InferedReturnIt+ | is_fun -- it *might* be a function, so we must "call" it (which is always safe) = SlowCall -- We cannot just enter it [in eval/apply, the entry code -- is the fast-entry code]@@ -568,13 +592,28 @@ DirectEntry (thunkEntryLabel (stgToCmmPlatform cfg) name (idCafInfo id) std_form_info updatable) 0 -getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info- = SlowCall -- might be a function+-- Imported(Unknown) Ids+getCallMethod cfg name id (LFUnknown might_be_a_function) n_args _v_args _cg_locs _self_loop_info+ | n_args == 0+ , Just sig <- idTagSig_maybe id+ , isTaggedSig sig -- Infered to be already evaluated by Tag Inference+ -- When profiling we enter functions to update the SCC so we+ -- can't use the infered enterInfo here.+ -- See Note [Evaluating functions with profiling] in rts/Apply.cmm+ , not (profileIsProfiling (stgToCmmProfile cfg) && might_be_a_function)+ = InferedReturnIt -- See Note [Tag Inference] -getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info- = assertPpr (n_args == 0) (ppr name <+> ppr n_args)- EnterIt -- Not a function+ | might_be_a_function = SlowCall + | otherwise =+ assertPpr ( n_args == 0) ( ppr name <+> ppr n_args )+ EnterIt -- Not a function++-- TODO: Redundant with above match?+-- getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info+-- = assertPpr (n_args == 0) (ppr name <+> ppr n_args)+-- EnterIt -- Not a function+ getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs) _self_loop_info = JumpToIt blk_id lne_regs @@ -809,23 +848,14 @@ LFThunk _ _ upd_flag (ApThunk arity) _ -> mkApInfoTableLabel platform upd_flag arity - LFThunk{} -> std_mk_lbl name cafs- LFReEntrant{} -> std_mk_lbl name cafs+ LFThunk{} -> mkInfoTableLabel name cafs+ LFReEntrant{} -> mkInfoTableLabel name cafs _other -> panic "closureInfoTableLabel" where name = idName id - std_mk_lbl | is_local = mkLocalInfoTableLabel- | otherwise = mkInfoTableLabel- cafs = idCafInfo id- is_local = isDataConWorkId id- -- Make the _info pointer for the implicit datacon worker- -- binding local. The reason we can do this is that importing- -- code always either uses the _closure or _con_info. By the- -- invariants in "GHC.CoreToStg.Prep" anything else gets eta expanded.- -- | thunkEntryLabel is a local help function, not exported. It's used from -- getCallMethod.
compiler/GHC/StgToCmm/DataCon.hs view
@@ -52,6 +52,8 @@ import Control.Monad import Data.Char import GHC.StgToCmm.Config (stgToCmmPlatform)+import GHC.StgToCmm.TagCheck (checkConArgsStatic, checkConArgsDyn)+import GHC.Utils.Outputable --------------------------------------------------------------- -- Top-level constructors@@ -93,7 +95,7 @@ -- Windows DLLs have a problem with static cross-DLL refs. massert (not (isDllConApp platform (stgToCmmExtDynRefs cfg) this_mod con (map fromNonVoid args))) ; assert (args `lengthIs` countConRepArgs con ) return ()-+ ; checkConArgsStatic (text "TagCheck failed - Top level con") con (map fromNonVoid args) -- LAY IT OUT ; let (tot_wds, -- #ptr_wds + #nonptr_wds@@ -210,6 +212,7 @@ ; let ticky_name | actually_bound = Just binder | otherwise = Nothing + ; checkConArgsDyn (text "TagCheck failed - con_alloc:" <> ppr binder) con (map fromNonVoid args) ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info use_cc blame_cc args_w_offsets ; return (mkRhsInit platform reg lf_info hp_plus_n) }@@ -227,7 +230,7 @@ For Char/Int closures there are some value closures built into the RTS. This is the case for all values in the range mINT_INTLIKE .. mAX_INTLIKE (or CHARLIKE).-See Note [CHARLIKE and INTLIKE closures.] in the RTS code.+See Note [CHARLIKE and INTLIKE closures] in the RTS code. Similarly zero-arity constructors have a closure in their defining Module we can use.
compiler/GHC/StgToCmm/Env.hs view
@@ -19,7 +19,7 @@ bindArgToReg, idToReg, getCgIdInfo, maybeLetNoEscape,- ) where+ ) where import GHC.Prelude @@ -44,7 +44,6 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain - ------------------------------------- -- Manipulating CgIdInfo -------------------------------------@@ -116,12 +115,20 @@ new_bindings setBinds new_binds +-- Inside GHC the average module creates 385 external references+-- with noteable cgIdInfo (so not generated by mkLFArgument).+-- On average 200 of these are covered by True/False/[]+-- and nullary constructors make up ~80.+-- One would think it would be worthwhile to cache these.+-- Sadly it's not. See #16937+ getCgIdInfo :: Id -> FCode CgIdInfo getCgIdInfo id = do { platform <- getPlatform ; local_binds <- getBinds -- Try local bindings first ; case lookupVarEnv local_binds id of {- Just info -> return info ;+ Just info -> -- pprTrace "getCgIdInfoLocal" (ppr id) $+ return info ; Nothing -> do { -- Should be imported; make up a CgIdInfo for it
compiler/GHC/StgToCmm/Expr.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE BangPatterns #-}- {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- --@@ -25,6 +26,7 @@ import GHC.StgToCmm.Lit import GHC.StgToCmm.Prim import GHC.StgToCmm.Hpc+import GHC.StgToCmm.TagCheck import GHC.StgToCmm.Ticky import GHC.StgToCmm.Utils import GHC.StgToCmm.Closure@@ -36,6 +38,7 @@ import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info import GHC.Cmm.Utils ( zeroExpr, cmmTagMask, mkWordCLit, mAX_PTR_TAG )+import GHC.Cmm.Ppr import GHC.Core import GHC.Core.DataCon import GHC.Types.ForeignCall@@ -56,6 +59,7 @@ import Control.Monad ( unless, void ) import Control.Arrow ( first ) import Data.List ( partition )+import GHC.Stg.InferTags.TagSig (isTaggedSig) ------------------------------------------------------------------------ -- cgExpr: the main function@@ -71,7 +75,7 @@ cgIdApp a [] -- dataToTag# :: a -> Int#--- See Note [dataToTag# magic] in primops.txt.pp+-- See Note [dataToTag# magic] in GHC.Core.Opt.ConstantFold cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do platform <- getPlatform emitComment (mkFastString "dataToTag#")@@ -291,7 +295,7 @@ entry to a function, when not many things are live. After a bunch of single-branch cases, we may have lots of things live -Hence: two basic plans for+Hence: Two basic plans for case e of r { alts } @@ -306,6 +310,13 @@ ...code for alts... ...alts do their own heap checks + When using GcInAlts the return point for heap checks and evaluating+ the scrutinee is shared. This does mean we might execute the actual+ branching code twice but it's rare enough to not matter.+ The huge advantage of this pattern is that we do not require multiple+ info tables for returning from gc as they can be shared between all+ cases. Reducing code size nicely.+ ------ Plan B: special case when --------- (i) e does not allocate or call GC (ii) either upstream code performs allocation@@ -320,6 +331,80 @@ ...code for alts... ...no heap check...++ There is a variant B.2 which we use if:++ (i) e is already evaluated+tagged+ (ii) We have multiple alternatives+ (iii) and there is no upstream allocation.++ Here we also place one heap check before the `case` which+ branches on `e`. Hopefully to be absorbed by an already existing+ heap check further up. However the big difference in this case is that+ there is no code for e. So we are not guaranteed that the heap+ checks of the alts will be combined with an heap check further up.++ Very common example: Casing on strict fields.++ ...heap check...+ ...assign bindings...++ ...code for alts...+ ...no heap check...++ -- Reasoning for Plan B.2:+ Since the scrutinee is already evaluated there is no evaluation+ call which would force a info table that we can use as a shared+ return point.+ This means currently if we were to do GcInAlts like in Plan A then+ we would end up with one info table per alternative.++ To avoid this we unconditionally do gc outside of the alts with all+ the pros and cons described in Note [Compiling case expressions].+ Rewriting the logic to generate a shared return point before the case+ expression while keeping the heap checks in the alternatives would be+ possible. But it's unclear to me that this would actually be an improvement.++ This means if we have code along these lines:++ g x y = case x of+ True -> Left $ (y + 1,y,y-1)+ False -> Right $! y - (2 :: Int)++ We get these potential heap check placements:++ f = ...+ !max(L,R)!; -- Might be absorbed upstream.+ case x of+ True -> !L!; ...L...+ False -> !R!; ...R...++ And we place a heap check at !max(L,R)!++ The downsides of using !max(L,R)! are:++ * If f is recursive, and the hot loop wouldn't allocate, but the exit branch does then we do+ a redundant heap check.+ * We use one more instruction to de-allocate the unused heap in the branch using less heap. (Neglible)+ * A small risk of running gc slightly more often than needed especially if one branch allocates a lot.++ The upsides are:+ * May save a heap overflow test if there is an upstream check already.+ * If the heap check is absorbed upstream we can also eliminate its info table.+ * We generate at most one heap check (versus one per alt otherwise).+ * No need to save volatile vars etc across heap checks in !L!, !R!+ * We can use relative addressing from a single Hp to get at all the closures so allocated. (seems neglible)+ * It fits neatly in the logic we already have for handling A/B++ For containers:Data/Sequence/Internal/Sorting.o the difference is+ about 10% in terms of code size compared to using Plan A for this case.+ The main downside is we might put heap checks into loops, even if we+ could avoid it (See Note [Compiling case expressions]).++ Potential improvement: Investigate if heap checks in alts would be an+ improvement if we generate and use a shared return point that is placed+ in the common path for all alts.+ -} @@ -461,11 +546,13 @@ ; up_hp_usg <- getVirtHp -- Upstream heap usage ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts alt_regs = map (idToReg platform) ret_bndrs+ ; simple_scrut <- isSimpleScrut scrut alt_type ; let do_gc | is_cmp_op scrut = False -- See Note [GC for conditionals] | not simple_scrut = True | isSingleton alts = False | up_hp_usg > 0 = False+ | evaluatedScrut = False | otherwise = True -- cf Note [Compiling case expressions] gc_plan = if do_gc then GcInAlts alt_regs else NoGcInAlts@@ -481,7 +568,14 @@ where is_cmp_op (StgOpApp (StgPrimOp op) _ _) = isComparisonPrimOp op is_cmp_op _ = False+ evaluatedScrut+ | (StgApp v []) <- scrut+ , Just sig <- idTagSig_maybe v+ , isTaggedSig sig = True+ | otherwise = False ++ {- Note [GC for conditionals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For boolean conditionals it seems that we have always done NoGcInAlts.@@ -530,15 +624,18 @@ -- heap usage from alternatives into the stuff before the case -- NB: if you get this wrong, and claim that the expression doesn't allocate -- when it does, you'll deeply mess up allocation-isSimpleScrut (StgOpApp op args _) _ = isSimpleOp op args-isSimpleScrut (StgLit _) _ = return True -- case 1# of { 0# -> ..; ... }-isSimpleScrut (StgApp _ []) (PrimAlt _) = return True -- case x# of { 0# -> ..; ... }-isSimpleScrut _ _ = return False+isSimpleScrut (StgOpApp op args _) _ = isSimpleOp op args+isSimpleScrut (StgLit _) _ = return True -- case 1# of { 0# -> ..; ... }+isSimpleScrut (StgApp _ []) (PrimAlt _) = return True -- case x# of { 0# -> ..; ... }+isSimpleScrut (StgApp f []) _+ | Just sig <- idTagSig_maybe f+ = return $! isTaggedSig sig -- case !x of { ... }+isSimpleScrut _ _ = return False isSimpleOp :: StgOp -> [StgArg] -> FCode Bool -- True iff the op cannot block or allocate isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe)--- dataToTag# evaluates its argument, see Note [dataToTag#] in primops.txt.pp+-- dataToTag# evaluates its argument, see Note [dataToTag# magic] in GHC.Core.Opt.ConstantFold isSimpleOp (StgPrimOp DataToTagOp) _ = return False isSimpleOp (StgPrimOp op) stg_args = do arg_exprs <- getNonVoidArgAmodes stg_args@@ -810,10 +907,10 @@ -- tricky part is that the default case needs (logical) duplication. -- To do this we emit an extra label for it and branch to that from -- the second switch. This avoids duplicated codegen. See Trac #14373.--- See note [Double switching for big families] for the mechanics+-- See Note [Double switching for big families] for the mechanics -- involved. ----- Also see note [Data constructor dynamic tags]+-- Also see Note [Data constructor dynamic tags] -- and the wiki https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/haskell-execution/pointer-tagging -- @@ -890,6 +987,7 @@ cgIdApp :: Id -> [StgArg] -> FCode ReturnKind cgIdApp fun_id args = do+ platform <- getPlatform fun_info <- getCgIdInfo fun_id cfg <- getStgToCmmConfig self_loop <- getSelfLoop@@ -904,8 +1002,26 @@ -- A value in WHNF, so we can just return it. ReturnIt | isZeroBitTy (idType fun_id) -> emitReturn []- | otherwise -> emitReturn [fun]- -- ToDo: does ReturnIt guarantee tagged?+ | otherwise -> emitReturn [fun]++ -- A value infered to be in WHNF, so we can just return it.+ InferedReturnIt+ | isZeroBitTy (idType fun_id) -> trace >> emitReturn []+ | otherwise -> trace >> assertTag >>+ emitReturn [fun]+ where+ trace = do+ tickyTagged+ use_id <- newUnique+ _lbl <- emitTickyCounterTag use_id (NonVoid fun_id)+ tickyTagSkip use_id fun_id++ -- pprTraceM "WHNF:" (ppr fun_id <+> ppr args )+ assertTag = whenCheckTags $ do+ mod <- getModuleName+ emitTagAssertion (showPprUnsafe+ (text "TagCheck failed on entry in" <+> ppr mod <+> text "- value:" <> ppr fun_id <+> pprExpr platform fun))+ fun EnterIt -> assert (null args) $ -- Discarding arguments emitEnter fun
compiler/GHC/StgToCmm/Foreign.hs view
@@ -127,7 +127,7 @@ } {- Note [safe foreign call convention]-+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The simple thing to do for a safe foreign call would be the same as an unsafe one: just @@ -174,7 +174,7 @@ L2: ... r ... -And when the safe foreign call is lowered later (see Note [lower safe+And when the safe foreign call is lowered later (see Note [Lower safe foreign calls]) we get this: suspendThread()@@ -303,10 +303,9 @@ , -- tso->stackobj->sp = Sp; mkStore (cmmOffset platform- (CmmLoad (cmmOffset platform+ (cmmLoadBWord platform (cmmOffset platform (CmmReg (CmmLocal tso))- (tso_stackobj profile))- (bWord platform))+ (tso_stackobj profile))) (stack_SP profile)) spExpr @@ -396,7 +395,7 @@ (widthInBytes $ typeWidth reg_ty) adj_sp = mkAssign spReg (cmmOffset platform spExpr width)- restore_reg = mkAssign (CmmGlobal reg) (CmmLoad spExpr reg_ty)+ restore_reg = mkAssign (CmmGlobal reg) (CmmLoad spExpr reg_ty NaturallyAligned) in mkCmmIfThen cond $ catAGraphs [restore_reg, adj_sp] emit . catAGraphs =<< mapM save_arg regs @@ -444,7 +443,7 @@ let alloc = CmmMachOp (mo_wordSub platform) [ cmmOffsetW platform hpExpr 1- , CmmLoad (nursery_bdescr_start platform cnreg) (bWord platform)+ , cmmLoadBWord platform (nursery_bdescr_start platform cnreg) ] alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit profile)@@ -452,7 +451,7 @@ -- tso->alloc_limit += alloc mkStore alloc_limit (CmmMachOp (MO_Sub W64)- [ CmmLoad alloc_limit b64+ [ CmmLoad alloc_limit b64 NaturallyAligned , CmmMachOp (mo_WordTo64 platform) [alloc] ]) ] @@ -473,9 +472,9 @@ -- tso = CurrentTSO; mkAssign (CmmLocal tso) currentTSOExpr, -- stack = tso->stackobj;- mkAssign (CmmLocal stack) (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_stackobj profile)) (bWord platform)),+ mkAssign (CmmLocal stack) (cmmLoadBWord platform (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_stackobj profile))), -- Sp = stack->sp;- mkAssign spReg (CmmLoad (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP profile)) (bWord platform)),+ mkAssign spReg (cmmLoadBWord platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP profile))), -- SpLim = stack->stack + RESERVED_STACK_WORDS; mkAssign spLimReg (cmmOffsetW platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_STACK profile)) (pc_RESERVED_STACK_WORDS (platformConstants platform))),@@ -486,9 +485,8 @@ open_nursery, -- and load the current cost centre stack from the TSO when profiling: if profileIsProfiling profile- then storeCurCCS- (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso))- (tso_CCCS profile)) (ccsType platform))+ then let ccs_ptr = cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS profile)+ in storeCurCCS (CmmLoad ccs_ptr (ccsType platform) NaturallyAligned) else mkNop ] @@ -543,12 +541,12 @@ -- stg_returnToStackTop in rts/StgStartup.cmm. pure $ catAGraphs [ mkAssign cnreg currentNurseryExpr,- mkAssign bdfreereg (CmmLoad (nursery_bdescr_free platform cnreg) (bWord platform)),+ mkAssign bdfreereg (cmmLoadBWord platform (nursery_bdescr_free platform cnreg)), -- Hp = CurrentNursery->free - 1; mkAssign hpReg (cmmOffsetW platform (CmmReg bdfreereg) (-1)), - mkAssign bdstartreg (CmmLoad (nursery_bdescr_start platform cnreg) (bWord platform)),+ mkAssign bdstartreg (cmmLoadBWord platform (nursery_bdescr_start platform cnreg)), -- HpLim = CurrentNursery->start + -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;@@ -556,11 +554,11 @@ (cmmOffsetExpr platform (CmmReg bdstartreg) (cmmOffset platform- (CmmMachOp (mo_wordMul platform) [- CmmMachOp (MO_SS_Conv W32 (wordWidth platform))- [CmmLoad (nursery_bdescr_blocks platform cnreg) b32],- mkIntExpr platform (pc_BLOCK_SIZE (platformConstants platform))- ])+ (CmmMachOp (mo_wordMul platform)+ [ CmmMachOp (MO_SS_Conv W32 (wordWidth platform))+ [CmmLoad (nursery_bdescr_blocks platform cnreg) b32 NaturallyAligned]+ , mkIntExpr platform (pc_BLOCK_SIZE (platformConstants platform))+ ]) (-1) ) ),@@ -574,7 +572,7 @@ -- tso->alloc_limit += alloc mkStore alloc_limit (CmmMachOp (MO_Add W64)- [ CmmLoad alloc_limit b64+ [ CmmLoad alloc_limit b64 NaturallyAligned , CmmMachOp (mo_WordTo64 platform) [alloc] ]) ]
compiler/GHC/StgToCmm/Heap.hs view
@@ -44,7 +44,6 @@ import GHC.Types.Id.Info( CafInfo(..), mayHaveCafRefs ) import GHC.Types.Id ( Id ) import GHC.Unit-import GHC.Driver.Session import GHC.Platform import GHC.Platform.Profile import GHC.Data.FastString( mkFastString, fsLit )@@ -491,6 +490,7 @@ _otherwise -> Nothing -- Note [stg_gc arguments]+-- ~~~~~~~~~~~~~~~~~~~~~~~ -- It might seem that we could avoid passing the arguments to the -- stg_gc function, because they are already in the right registers. -- While this is usually the case, it isn't always. Sometimes the@@ -670,7 +670,6 @@ -- Note [Self-recursive loop header] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- -- Self-recursive loop header is required by loopification optimization (See -- Note [Self-recursive tail calls] in GHC.StgToCmm.Expr). We emit it if: --
compiler/GHC/StgToCmm/Hpc.hs view
@@ -27,7 +27,7 @@ mkTickBox :: Platform -> Module -> Int -> CmmAGraph mkTickBox platform mod n = mkStore tick_box (CmmMachOp (MO_Add W64)- [ CmmLoad tick_box b64+ [ CmmLoad tick_box b64 NaturallyAligned , CmmLit (CmmInt 1 W64) ]) where
compiler/GHC/StgToCmm/Layout.hs view
@@ -90,7 +90,7 @@ ; case sequel of Return -> do { adjustHpBackwards- ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord platform)+ ; let e = cmmLoadGCWord platform (CmmStackSlot Old updfr_off) ; emit (mkReturn profile (entryCode platform e) results updfr_off) } AssignTo regs adjust ->@@ -212,7 +212,7 @@ " with pat " ++ unpackFS rts_fun) return r - -- Note [avoid intermediate PAPs]+ -- See Note [avoid intermediate PAPs] let n_args = length stg_args if n_args > arity && fast_pap then do@@ -261,7 +261,7 @@ -- Note [avoid intermediate PAPs]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- A slow call which needs multiple generic apply patterns will be -- almost guaranteed to create one or more intermediate PAPs when -- applied to a function that takes the correct number of arguments.@@ -339,7 +339,7 @@ {- Note [over-saturated calls]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~ The natural thing to do for an over-saturated call would be to call the function with the correct number of arguments, and then apply the remaining arguments to the value returned, e.g.
compiler/GHC/StgToCmm/Monad.hs view
@@ -21,7 +21,7 @@ emit, emitDecl, emitProcWithConvention, emitProcWithStackFrame,- emitOutOfLine, emitAssign, emitStore,+ emitOutOfLine, emitAssign, emitStore, emitStore', emitComment, emitTick, emitUnwind, newTemp,@@ -203,7 +203,7 @@ | ReturnedTo BlockId ByteOff -- Note [sharing continuations]---+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- ReturnKind says how the expression being compiled returned its -- results: either by assigning directly to the registers specified -- by the Sequel, or by returning to a continuation that does the@@ -724,8 +724,12 @@ emitAssign :: CmmReg -> CmmExpr -> FCode () emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r)) -emitStore :: CmmExpr -> CmmExpr -> FCode ()-emitStore l r = emitCgStmt (CgStmt (CmmStore l r))+-- | Assumes natural alignment.+emitStore :: CmmExpr -> CmmExpr -> FCode ()+emitStore = emitStore' NaturallyAligned++emitStore' :: AlignmentSpec -> CmmExpr -> CmmExpr -> FCode ()+emitStore' alignment l r = emitCgStmt (CgStmt (CmmStore l r alignment)) emit :: CmmAGraph -> FCode () emit ag
compiler/GHC/StgToCmm/Prim.hs view
@@ -29,14 +29,13 @@ import GHC.StgToCmm.Heap import GHC.StgToCmm.Prof ( costCentreFrom ) -import GHC.Driver.Session import GHC.Types.Basic import GHC.Cmm.BlockId import GHC.Cmm.Graph import GHC.Stg.Syntax import GHC.Cmm import GHC.Unit ( rtsUnit )-import GHC.Core.Type ( Type, tyConAppTyCon )+import GHC.Core.Type ( Type, tyConAppTyCon_maybe ) import GHC.Core.TyCon import GHC.Cmm.CLabel import GHC.Cmm.Info ( closureInfoPtr )@@ -50,6 +49,7 @@ import Data.Maybe import Control.Monad (liftM, when, unless)+import GHC.Utils.Outputable ------------------------------------------------------------------------ -- Primitive operations and foreign calls@@ -74,7 +74,7 @@ -- Foreign calls cgOpApp (StgFCallOp fcall ty) stg_args res_ty = cgForeignCall fcall ty stg_args res_ty- -- Note [Foreign call results]+ -- See Note [Foreign call results] cgOpApp (StgPrimOp primop) args res_ty = do cfg <- getStgToCmmConfig@@ -1543,7 +1543,7 @@ -- you used tagToEnum# in a non-monomorphic setting, e.g., -- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x# -- That won't work.- let tycon = tyConAppTyCon res_ty+ let tycon = fromMaybe (pprPanic "tagToEnum#: Applied to non-concrete type" (ppr res_ty)) (tyConAppTyCon_maybe res_ty) massert (isEnumerationTyCon tycon) platform <- getPlatform pure [tagToClosure platform tycon amode]@@ -1716,7 +1716,6 @@ alwaysExternal = \_ -> PrimopCmmEmit_External -- Note [QuotRem optimization] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~- -- -- `quot` and `rem` with constant divisor can be implemented with fast bit-ops -- (shift, .&.). --@@ -2058,13 +2057,20 @@ ------------------------------------------------------------------------------ -- Helpers for translating various minor variants of array indexing. +alignmentFromTypes :: CmmType -- ^ element type+ -> CmmType -- ^ index type+ -> AlignmentSpec+alignmentFromTypes ty idx_ty+ | typeWidth ty < typeWidth idx_ty = NaturallyAligned+ | otherwise = Unaligned+ doIndexOffAddrOp :: Maybe MachOp -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode () doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]- = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr rep idx+ = mkBasicIndexedRead NaturallyAligned 0 maybe_post_read_cast rep res addr rep idx doIndexOffAddrOp _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexOffAddrOp" @@ -2075,7 +2081,8 @@ -> [CmmExpr] -> FCode () doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]- = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx_rep idx+ = let alignment = alignmentFromTypes rep idx_rep+ in mkBasicIndexedRead alignment 0 maybe_post_read_cast rep res addr idx_rep idx doIndexOffAddrOpAs _ _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexOffAddrOpAs" @@ -2087,7 +2094,7 @@ doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx] = do profile <- getProfile doByteArrayBoundsCheck idx addr rep rep- mkBasicIndexedRead (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx+ mkBasicIndexedRead NaturallyAligned (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx doIndexByteArrayOp _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp" @@ -2100,7 +2107,8 @@ doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx] = do profile <- getProfile doByteArrayBoundsCheck idx addr idx_rep rep- mkBasicIndexedRead (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx+ let alignment = alignmentFromTypes rep idx_rep+ mkBasicIndexedRead alignment (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx doIndexByteArrayOpAs _ _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs" @@ -2112,7 +2120,7 @@ = do profile <- getProfile platform <- getPlatform doPtrArrayBoundsCheck idx addr- mkBasicIndexedRead (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx+ mkBasicIndexedRead NaturallyAligned (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx doWriteOffAddrOp :: Maybe MachOp -> CmmType@@ -2151,7 +2159,7 @@ -- Update remembered set for non-moving collector whenUpdRemSetEnabled- $ emitUpdRemSetPush (cmmLoadIndexOffExpr platform hdr_size ty addr ty idx)+ $ emitUpdRemSetPush (cmmLoadIndexOffExpr platform NaturallyAligned hdr_size ty addr ty idx) -- This write barrier is to ensure that the heap writes to the object -- referred to by val have happened before we write val into the array. -- See #12469 for details.@@ -2165,16 +2173,16 @@ cmmOffsetExpr platform (cmmOffsetExprW platform (cmmOffsetB platform addr hdr_size) (loadArrPtrsSize profile addr))- (CmmMachOp (mo_wordUShr platform) [idx,- mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))])+ (CmmMachOp (mo_wordUShr platform) [idx, mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))]) ) (CmmLit (CmmInt 1 W8)) loadArrPtrsSize :: Profile -> CmmExpr -> CmmExpr-loadArrPtrsSize profile addr = CmmLoad (cmmOffsetB platform addr off) (bWord platform)+loadArrPtrsSize profile addr = cmmLoadBWord platform (cmmOffsetB platform addr off) where off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (profileConstants profile) platform = profilePlatform profile -mkBasicIndexedRead :: ByteOff -- Initial offset in bytes+mkBasicIndexedRead :: AlignmentSpec+ -> ByteOff -- Initial offset in bytes -> Maybe MachOp -- Optional result cast -> CmmType -- Type of element we are accessing -> LocalReg -- Destination@@ -2182,13 +2190,13 @@ -> CmmType -- Type of element by which we are indexing -> CmmExpr -- Index -> FCode ()-mkBasicIndexedRead off Nothing ty res base idx_ty idx+mkBasicIndexedRead alignment off Nothing ty res base idx_ty idx = do platform <- getPlatform- emitAssign (CmmLocal res) (cmmLoadIndexOffExpr platform off ty base idx_ty idx)-mkBasicIndexedRead off (Just cast) ty res base idx_ty idx+ emitAssign (CmmLocal res) (cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx)+mkBasicIndexedRead alignment off (Just cast) ty res base idx_ty idx = do platform <- getPlatform emitAssign (CmmLocal res) (CmmMachOp cast [- cmmLoadIndexOffExpr platform off ty base idx_ty idx])+ cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx]) mkBasicIndexedWrite :: ByteOff -- Initial offset in bytes -> Maybe MachOp -- Optional value cast@@ -2199,7 +2207,8 @@ -> FCode () mkBasicIndexedWrite off Nothing base idx_ty idx val = do platform <- getPlatform- emitStore (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) val+ let alignment = alignmentFromTypes (cmmExprType platform val) idx_ty+ emitStore' alignment (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) val mkBasicIndexedWrite off (Just cast) base idx_ty idx val = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val]) @@ -2216,14 +2225,15 @@ = cmmIndexExpr platform width (cmmOffsetB platform base off) idx cmmLoadIndexOffExpr :: Platform+ -> AlignmentSpec -> ByteOff -- Initial offset in bytes -> CmmType -- Type of element we are accessing -> CmmExpr -- Base address -> CmmType -- Type of element by which we are indexing -> CmmExpr -- Index -> CmmExpr-cmmLoadIndexOffExpr platform off ty base idx_ty idx- = CmmLoad (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) ty+cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx+ = CmmLoad (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) ty alignment setInfo :: CmmExpr -> CmmExpr -> CmmAGraph setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr@@ -2989,7 +2999,7 @@ profile <- getProfile platform <- getPlatform doSmallPtrArrayBoundsCheck idx addr- mkBasicIndexedRead (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr+ mkBasicIndexedRead NaturallyAligned (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx doWriteSmallPtrArrayOp :: CmmExpr@@ -3005,7 +3015,7 @@ -- Update remembered set for non-moving collector tmp <- newTemp ty- mkBasicIndexedRead (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx+ mkBasicIndexedRead NaturallyAligned (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx whenUpdRemSetEnabled $ emitUpdRemSetPush (CmmReg (CmmLocal tmp)) emitPrimCall [] MO_WriteBarrier [] -- #12469@@ -3259,7 +3269,7 @@ doPtrArrayBoundsCheck idx arr = do profile <- getProfile platform <- getPlatform- let sz = CmmLoad (cmmOffsetB platform arr sz_off) (bWord platform)+ let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off) sz_off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform) doBoundsCheck idx sz @@ -3270,7 +3280,7 @@ doSmallPtrArrayBoundsCheck idx arr = do profile <- getProfile platform <- getPlatform- let sz = CmmLoad (cmmOffsetB platform arr sz_off) (bWord platform)+ let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off) sz_off = fixedHdrSize profile + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform) doBoundsCheck idx sz @@ -3283,7 +3293,7 @@ doByteArrayBoundsCheck idx arr idx_ty elem_ty = do profile <- getProfile platform <- getPlatform- let sz = CmmLoad (cmmOffsetB platform arr sz_off) (bWord platform)+ let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off) sz_off = fixedHdrSize profile + pc_OFFSET_StgArrBytes_bytes (platformConstants platform) elem_sz = widthInBytes $ typeWidth elem_ty idx_sz = widthInBytes $ typeWidth idx_ty
compiler/GHC/StgToCmm/Prof.hs view
@@ -28,8 +28,6 @@ import GHC.Prelude -import GHC.Driver.Session- import GHC.Platform import GHC.Platform.Profile import GHC.StgToCmm.Closure@@ -85,7 +83,7 @@ costCentreFrom :: Platform -> CmmExpr -- A closure pointer -> CmmExpr -- The cost centre from that closure-costCentreFrom platform cl = CmmLoad (cmmOffsetB platform cl (pc_OFFSET_StgHeader_ccs (platformConstants platform))) (ccsType platform)+costCentreFrom platform cl = CmmLoad (cmmOffsetB platform cl (pc_OFFSET_StgHeader_ccs (platformConstants platform))) (ccsType platform) NaturallyAligned -- | The profiling header words in a static closure staticProfHdr :: Profile -> CostCentreStack -> [CmmLit]@@ -396,7 +394,7 @@ -- don't forget to subtract node's tag ldv_wd = ldvWord platform cl_ptr new_ldv_wd = cmmOrWord platform- (cmmAndWord platform (CmmLoad ldv_wd (bWord platform))+ (cmmAndWord platform (cmmLoadBWord platform ldv_wd) (CmmLit (mkWordCLit platform (pc_ILDV_CREATE_MASK constants)))) (cmmOrWord platform (loadEra platform) (CmmLit (mkWordCLit platform (pc_ILDV_STATE_USE constants)))) ifProfiling $@@ -410,7 +408,8 @@ loadEra :: Platform -> CmmExpr loadEra platform = CmmMachOp (MO_UU_Conv (cIntWidth platform) (wordWidth platform)) [CmmLoad (mkLblExpr (mkRtsCmmDataLabel (fsLit "era")))- (cInt platform)]+ (cInt platform)+ NaturallyAligned] -- | Takes the address of a closure, and returns -- the address of the LDV word in the closure
+ compiler/GHC/StgToCmm/TagCheck.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Code generator utilities; mostly monadic+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.TagCheck+ ( emitTagAssertion, emitArgTagCheck, checkArg, whenCheckTags,+ checkArgStatic, checkFunctionArgTags,checkConArgsStatic,checkConArgsDyn) where++#include "ClosureTypes.h"++import GHC.Prelude++import GHC.StgToCmm.Env+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Utils+import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.Cmm.Graph as CmmGraph++import GHC.Core.Type+import GHC.Types.Id+import GHC.Utils.Misc+import GHC.Utils.Outputable++import GHC.Core.DataCon+import Control.Monad+import GHC.StgToCmm.Types+import GHC.Utils.Panic (pprPanic)+import GHC.Utils.Panic.Plain (panic)+import GHC.Stg.Syntax+import GHC.StgToCmm.Closure+import GHC.Types.RepType (dataConRuntimeRepStrictness)+import GHC.Types.Basic+import GHC.Data.FastString (mkFastString)+import GHC.Cmm.Info (cmmGetClosureType)+import GHC.Cmm.Utils (mkWordCLit)++-- | Check all arguments marked as already tagged for a function+-- are tagged by inserting runtime checks.+checkFunctionArgTags :: SDoc -> Id -> [Id] -> FCode ()+checkFunctionArgTags msg f args = whenCheckTags $ do+ onJust (return ()) (idCbvMarks_maybe f) $ \marks -> do+ -- Only check args marked as strict, and only lifted ones.+ let cbv_args = filter (isLiftedRuntimeRep . idType) $ filterByList (map isMarkedCbv marks) args+ -- Get their (cmm) address+ arg_infos <- mapM getCgIdInfo cbv_args+ let arg_cmms = map idInfoToAmode arg_infos+ mapM_ (emitTagAssertion (showPprUnsafe msg)) (arg_cmms)++-- | Check all required-tagged arguments of a constructor are tagged *at compile time*.+checkConArgsStatic :: SDoc -> DataCon -> [StgArg] -> FCode ()+checkConArgsStatic msg con args = whenCheckTags $ do+ let marks = dataConRuntimeRepStrictness con+ zipWithM_ (checkArgStatic msg) marks args++-- Check all required arguments of a constructor are tagged.+-- Possible by emitting checks at runtime.+checkConArgsDyn :: SDoc -> DataCon -> [StgArg] -> FCode ()+checkConArgsDyn msg con args = whenCheckTags $ do+ let marks = dataConRuntimeRepStrictness con+ zipWithM_ (checkArg msg) (map cbvFromStrictMark marks) args++whenCheckTags :: FCode () -> FCode ()+whenCheckTags act = do+ check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig+ when check_tags act++-- | Call barf if we failed to predict a tag correctly.+-- This is immensly useful when debugging issues in tag inference+-- as it will result in a program abort when we encounter an invalid+-- call/heap object, rather than leaving it be and segfaulting arbitrary+-- or producing invalid results.+-- We check if either:+-- * A tag is present+-- * Or the object is a PAP (for which zero is the proper tag)+emitTagAssertion :: String -> CmmExpr -> FCode ()+emitTagAssertion onWhat fun = do+ { platform <- getPlatform+ ; lret <- newBlockId+ ; lno_tag <- newBlockId+ ; lbarf <- newBlockId+ -- Check for presence of any tag.+ ; emit $ mkCbranch (cmmIsTagged platform fun)+ lret lno_tag (Just True)+ -- If there is no tag check if we are dealing with a PAP+ ; emitLabel lno_tag+ ; emitComment (mkFastString "closereTypeCheck")+ ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig+ ; profile <- getProfile+ ; let closure_ty = cmmGetClosureType profile align_check fun+ ; ty_reg <- newTemp (bWord platform)+ ; emitAssign (CmmLocal ty_reg) closure_ty+ ; emit $ mkCbranch (cmmEqWord platform+ (CmmReg $ CmmLocal ty_reg)+ (CmmLit $ mkWordCLit platform PAP))+ lret lbarf (Just True)++ ; emitLabel lbarf+ ; emitBarf ("Tag inference failed on:" ++ onWhat)+ ; emitLabel lret+ }++emitArgTagCheck :: SDoc -> [CbvMark] -> [Id] -> FCode ()+emitArgTagCheck info marks args = whenCheckTags $ do+ mod <- getModuleName+ let cbv_args = filter (isLiftedRuntimeRep . idType) $ filterByList (map isMarkedCbv marks) args+ arg_infos <- mapM getCgIdInfo cbv_args+ let arg_cmms = map idInfoToAmode arg_infos+ mk_msg arg = showPprUnsafe (text "Untagged arg:" <> (ppr mod) <> char ':' <> info <+> ppr arg)+ zipWithM_ emitTagAssertion (map mk_msg args) (arg_cmms)++taggedCgInfo :: CgIdInfo -> Bool+taggedCgInfo cg_info+ = case lf of+ LFCon {} -> True+ LFReEntrant {} -> True+ LFUnlifted {} -> True+ LFThunk {} -> False+ LFUnknown {} -> False+ LFLetNoEscape -> panic "Let no escape binding passed to top level con"+ where+ lf = cg_lf cg_info++-- Check that one argument is properly tagged.+checkArg :: SDoc -> CbvMark -> StgArg -> FCode ()+checkArg _ NotMarkedCbv _ = return ()+checkArg msg MarkedCbv arg = whenCheckTags $+ case arg of+ StgLitArg _ -> return ()+ StgVarArg v -> do+ info <- getCgIdInfo v+ if taggedCgInfo info+ then return ()+ else case (cg_loc info) of+ CmmLoc loc -> emitTagAssertion (showPprUnsafe msg) loc+ LneLoc {} -> panic "LNE-arg"++-- Check that argument is properly tagged.+checkArgStatic :: SDoc -> StrictnessMark -> StgArg -> FCode ()+checkArgStatic _ NotMarkedStrict _ = return ()+checkArgStatic msg MarkedStrict arg = whenCheckTags $+ case arg of+ StgLitArg _ -> return ()+ StgVarArg v -> do+ info <- getCgIdInfo v+ if taggedCgInfo info+ then return ()+ else pprPanic "Arg not tagged as expectd" (ppr msg <+> ppr arg)++
compiler/GHC/StgToCmm/Ticky.hs view
@@ -64,6 +64,15 @@ * someone else might know how to repair it! ++Note [Ticky counters are static]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Currently GHC only supports static ticky events. That is -ticky emits+code containing labels containing counters which then get bumped at runtime.++There are currently only *static* ticky counters. Either we bump one of the+static counters included in the RTS. Or we emit StgEntCounter structures in+the object code and bump these. -} module GHC.StgToCmm.Ticky (@@ -72,6 +81,7 @@ withNewTickyCounterThunk, withNewTickyCounterStdThunk, withNewTickyCounterCon,+ emitTickyCounterTag, tickyDynAlloc, tickyAllocHeap,@@ -97,7 +107,10 @@ tickyUnboxedTupleReturn, tickyReturnOldCon, tickyReturnNewCon, - tickySlowCall+ tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,+ tickySlowCall, tickySlowCallPat,++ tickyTagged, tickyUntagged, tickyTagSkip ) where import GHC.Prelude@@ -260,6 +273,93 @@ ] } +{- Note [TagSkip ticky counters]+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+These counters keep track how often we execute code where we+would have performed a tag check if we hadn't run tag inference.++If we have some code of the form:+ case v[tagged] of ...+and we want to record how often we avoid a tag check on v+through tag inference we have to emit a new StgEntCounter for+each such case statement in order to record how often it's executed.++In theory we could emit one per *binding*. But then we+would have to either keep track of the bindings which+already have a StgEntCounter associated with them in the+code gen state or preallocate such a structure for each binding+in the code unconditionally (since ticky-code can call non-ticky code)++The first makes the compiler slower, even when ticky is not+used (a big no no). The later is fairly complex but increases code size+unconditionally. See also Note [Ticky counters are static].++So instead we emit a new StgEntCounter for each use site of a binding+where we infered a tag to be present. And increment the counter whenever+this use site is executed.++We use the fields as follows:++entry_count: Entries avoided.+str: : Name of the id.++We use emitTickyCounterTag to emit the counter.++Unlike the closure counters each *use* site of v has it's own+counter. So there is no need to keep track of the closure/case we are+in.++We also have to pass a unique for the counter. An Id might be+scrutinized in more than one place, so the ID alone isn't enough+to distinguish between use sites.+-}++emitTickyCounterTag :: Unique -> NonVoid Id -> FCode CLabel+emitTickyCounterTag unique (NonVoid id) =+ let name = idName id+ ctr_lbl = mkTagHitLabel name unique in+ (>> return ctr_lbl) $+ ifTickyTag $ do+ { platform <- getPlatform+ ; parent <- getTickyCtrLabel+ ; mod_name <- getModuleName++ -- When printing the name of a thing in a ticky file, we+ -- want to give the module name even for *local* things. We+ -- print just "x (M)" rather that "M.x" to distinguish them+ -- from the global kind.+ ; let ppr_for_ticky_name :: SDoc+ ppr_for_ticky_name =+ let n = ppr name+ ext = empty -- parens (text "tagged")+ p = case hasHaskellName parent of+ -- NB the default "top" ticky ctr does not+ -- have a Haskell name+ Just pname -> text "at" <+> ppr (nameSrcLoc pname) <+>+ text "in" <+> pprNameUnqualified name+ _ -> empty+ in if isInternalName name+ then n <+> parens (ppr mod_name) <+> ext <+> p+ else n <+> ext <+> p+ ; sdoc_context <- stgToCmmContext <$> getStgToCmmConfig+ ; fun_descr_lit <- newStringCLit $ renderWithContext sdoc_context ppr_for_ticky_name+ ; arg_descr_lit <- newStringCLit $ "infer"+ ; emitDataLits ctr_lbl+ -- Must match layout of includes/rts/Ticky.h's StgEntCounter+ --+ -- krc: note that all the fields are I32 now; some were I16+ -- before, but the code generator wasn't handling that+ -- properly and it led to chaos, panic and disorder.+ [ mkIntCLit platform 0, -- registered?+ mkIntCLit platform 0, -- Arity+ mkIntCLit platform 0, -- Heap allocated for this thing+ fun_descr_lit,+ arg_descr_lit,+ zeroCLit platform, -- Entries into this thing+ zeroCLit platform, -- Heap allocated by this thing+ zeroCLit platform -- Link to next StgEntCounter+ ]+ } -- ----------------------------------------------------------------------------- -- Ticky stack frames @@ -374,7 +474,7 @@ let locked = cmmEqWord platform (CmmReg $ CmmLocal old) (zeroExpr platform) emit =<< mkCmmIfThen locked register_stmts - let test = cmmEqWord platform (CmmLoad registeredp (bWord platform)) (zeroExpr platform)+ let test = cmmEqWord platform (cmmLoadBWord platform registeredp) (zeroExpr platform) emit =<< mkCmmIfThen test cas_test tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode ()@@ -560,6 +660,27 @@ tickyStackCheck = ifTicky $ bumpTickyCounter (fsLit "STK_CHK_ctr") -- -----------------------------------------------------------------------------+-- Ticky for tag inference characterisation++-- | Predicted a pointer would be tagged correctly (GHC will crash if not so no miss case)+tickyTagged :: FCode ()+tickyTagged = ifTickyTag $ bumpTickyCounter (fsLit "TAG_TAGGED_pred")++-- | Pass a boolean expr indicating if tag was present.+tickyUntagged :: CmmExpr -> FCode ()+tickyUntagged e = do+ ifTickyTag $ bumpTickyCounter (fsLit "TAG_UNTAGGED_pred")+ ifTickyTag $ bumpTickyCounterByE (fsLit "TAG_UNTAGGED_miss") e++-- | Called when for `case v of ...` we can avoid entering v based on+-- tag inference information.+tickyTagSkip :: Unique -> Id -> FCode ()+tickyTagSkip unique id = ifTickyTag $ do+ let ctr_lbl = mkTagHitLabel (idName id) unique+ registerTickyCtr ctr_lbl+ bumpTickyTagSkip ctr_lbl++-- ----------------------------------------------------------------------------- -- Ticky utils isEnabled :: (StgToCmmConfig -> Bool) -> FCode Bool@@ -571,6 +692,9 @@ ifTicky :: FCode () -> FCode () ifTicky = runIfFlag stgToCmmDoTicky +ifTickyTag :: FCode () -> FCode ()+ifTickyTag = runIfFlag stgToCmmTickyTag+ ifTickyAllocd :: FCode () -> FCode () ifTickyAllocd = runIfFlag stgToCmmTickyAllocd @@ -597,7 +721,12 @@ bumpTickyAllocd :: CLabel -> Int -> FCode () bumpTickyAllocd lbl bytes = do platform <- getPlatform- bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_allocd (platformConstants platform))) bytes+ bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform))) bytes++bumpTickyTagSkip :: CLabel -> FCode ()+bumpTickyTagSkip lbl = do+ platform <- getPlatform+ bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform))) 1 bumpTickyLbl :: CLabel -> FCode () bumpTickyLbl lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) 1
compiler/GHC/StgToCmm/Utils.hs view
@@ -12,7 +12,8 @@ emitDataLits, emitRODataLits, emitDataCon, emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,- assignTemp,+ emitBarf,+ assignTemp, newTemp, newUnboxedTupleRegs, @@ -50,7 +51,7 @@ import GHC.Platform import GHC.StgToCmm.Monad import GHC.StgToCmm.Closure-import GHC.StgToCmm.Lit (mkSimpleLit)+import GHC.StgToCmm.Lit (mkSimpleLit, newStringCLit) import GHC.Cmm import GHC.Cmm.BlockId import GHC.Cmm.Graph as CmmGraph@@ -102,18 +103,20 @@ addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl)) +-- | @addToMem rep ptr n@ adds @n@ to the integer pointed-to by @ptr@. addToMem :: CmmType -- rep of the counter- -> CmmExpr -- Address+ -> CmmExpr -- Naturally-aligned address -> Int -- What to add (a word) -> CmmAGraph addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep))) +-- | @addToMemE rep ptr n@ adds @n@ to the integer pointed-to by @ptr@. addToMemE :: CmmType -- rep of the counter- -> CmmExpr -- Address+ -> CmmExpr -- Naturally-aligned address -> CmmExpr -- What to add (a word-typed expression) -> CmmAGraph addToMemE rep ptr n- = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n])+ = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep NaturallyAligned, n]) -------------------------------------------------------------------------@@ -133,7 +136,8 @@ (CmmLoad (cmmOffsetB platform (CmmReg (CmmLocal base)) (offset - tag))- (localRegType reg))+ (localRegType reg)+ NaturallyAligned) ------------------------------------------------------------------------- --@@ -144,7 +148,7 @@ tagToClosure :: Platform -> TyCon -> CmmExpr -> CmmExpr tagToClosure platform tycon tag- = CmmLoad (cmmOffsetExprW platform closure_tbl tag) (bWord platform)+ = cmmLoadBWord platform (cmmOffsetExprW platform closure_tbl tag) where closure_tbl = CmmLit (CmmLabel lbl) lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs @@ -154,6 +158,11 @@ -- ------------------------------------------------------------------------- +emitBarf :: String -> FCode ()+emitBarf msg = do+ strLbl <- newStringCLit msg+ emitRtsCall rtsUnitId (fsLit "barf") [(CmmLit strLbl,AddrHint)] False+ emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () emitRtsCall pkg fun = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) @@ -236,7 +245,9 @@ callerRestoreGlobalReg :: Platform -> GlobalReg -> CmmAGraph callerRestoreGlobalReg platform reg = mkAssign (CmmGlobal reg)- (CmmLoad (get_GlobalReg_addr platform reg) (globalRegType platform reg))+ (CmmLoad (get_GlobalReg_addr platform reg)+ (globalRegType platform reg)+ NaturallyAligned) -------------------------------------------------------------------------@@ -294,8 +305,6 @@ choose_regs _ (AssignTo regs _) = return regs choose_regs platform _ = mapM (newTemp . primRepCmmType platform) reps -- ------------------------------------------------------------------------- -- emitMultiAssign -------------------------------------------------------------------------@@ -559,7 +568,7 @@ platform <- getPlatform do_it <- getCode code let- enabled = CmmLoad (CmmLit $ CmmLabel mkNonmovingWriteBarrierEnabledLabel) (bWord platform)+ enabled = cmmLoadBWord platform (CmmLit $ CmmLabel mkNonmovingWriteBarrierEnabledLabel) zero = zeroExpr platform is_enabled = cmmNeWord platform enabled zero the_if <- mkCmmIfThenElse' is_enabled do_it mkNop (Just False)
compiler/GHC/SysTools.hs view
@@ -156,8 +156,8 @@ Left (SettingsError_MissingData msg) -> pgmError msg Left (SettingsError_BadData msg) -> pgmError msg -{- Note [Windows stack usage]-+{- Note [Windows stack allocations]+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See: #8870 (and #8834 for related info) and #12186 On Windows, occasionally we need to grow the stack. In order to do
compiler/GHC/SysTools/Info.hs view
@@ -26,14 +26,12 @@ import GHC.SysTools.Process {- Note [Run-time linker info]-+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~ See also: #5240, #6063, #10110 Before 'runLink', we need to be sure to get the relevant information about the linker we're using at runtime to see if we need any extra-options. For example, GNU ld requires '--reduce-memory-overheads' and-'--hash-size=31' in order to use reasonable amounts of memory (see-trac #5240.) But this isn't supported in GNU gold.+options. Generally, the linker changing from what was detected at ./configure time has always been possible using -pgml, but on Linux it can happen@@ -57,7 +55,7 @@ -} {- Note [ELF needed shared libs]-+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Some distributions change the link editor's default handling of ELF DT_NEEDED tags to include only those shared objects that are needed to resolve undefined symbols. For Template Haskell we need@@ -71,7 +69,7 @@ -} {- Note [Windows static libGCC]-+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The GCC versions being upgraded to in #10726 are configured with dynamic linking of libgcc supported. This results in libgcc being linked dynamically when a shared library is created.@@ -127,13 +125,8 @@ -- Try to grab the info from the process output. parseLinkerInfo stdo _stde _exitc | any ("GNU ld" `isPrefixOf`) stdo =- -- GNU ld specifically needs to use less memory. This especially- -- hurts on small object files. #5240. -- Set DT_NEEDED for all shared libraries. #10110.- -- TODO: Investigate if these help or hurt when using split sections.- return (GnuLD $ map Option ["-Wl,--hash-size=31",- "-Wl,--reduce-memory-overheads",- -- ELF specific flag+ return (GnuLD $ map Option [-- ELF specific flag -- see Note [ELF needed shared libs] "-Wl,--no-as-needed"]) @@ -173,14 +166,11 @@ -- 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"+ [ -- Emit gcc stack checks+ -- See Note [Windows stack allocations]+ "-fstack-check" -- Force static linking of libGCC- -- Note [Windows static libGCC]+ -- See Note [Windows static libGCC] , "-static-libgcc" ] _ -> do -- In practice, we use the compiler as the linker here. Pass
compiler/GHC/Tc/Deriv/Generate.hs view
@@ -70,11 +70,10 @@ import GHC.Builtin.Types import GHC.Core.Type import GHC.Core.Class-import GHC.Types.Unique.FM ( lookupUFM )+import GHC.Types.Unique.FM ( lookupUFM, listToUFM ) import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Utils.Misc-import GHC.Types.Unique.FM ( listToUFM ) import GHC.Types.Var import GHC.Utils.Outputable import GHC.Utils.Panic
compiler/GHC/Tc/Deriv/Infer.hs view
@@ -42,6 +42,7 @@ import GHC.Core.TyCo.Ppr (pprTyVars) import GHC.Core.Type import GHC.Tc.Solver+import GHC.Tc.Solver.Monad ( runTcS ) import GHC.Tc.Validity (validDerivPred) import GHC.Tc.Utils.Unify (buildImplicationFor, checkConstraints) import GHC.Builtin.Types (typeToTypeKind)@@ -788,10 +789,10 @@ -- Simplify the constraints, starting at the same level at which -- they are generated (c.f. the call to runTcSWithEvBinds in -- simplifyInfer)- ; solved_wanteds <- setTcLevel tc_lvl $- runTcSDeriveds $- solveWantedsAndDrop $- unionsWC wanteds+ ; (solved_wanteds, _) <- setTcLevel tc_lvl $+ runTcS $+ solveWanteds $+ unionsWC wanteds -- It's not yet zonked! Obviously zonk it before peering at it ; solved_wanteds <- zonkWC solved_wanteds@@ -809,16 +810,10 @@ -- constitutes an exotic constraint. get_good :: Ct -> Maybe PredType get_good ct | validDerivPred skol_set p- , isWantedCt ct = Just p- -- TODO: This is wrong- -- NB re 'isWantedCt': residual_wanted may contain- -- unsolved CtDerived and we stick them into the- -- bad set so that reportUnsolved may decide what- -- to do with them | otherwise = Nothing- where p = ctPred ct+ where p = ctPred ct ; traceTc "simplifyDeriv outputs" $ vcat [ ppr tvs_skols, ppr residual_simple, ppr good ]
compiler/GHC/Tc/Deriv/Utils.hs view
@@ -625,7 +625,7 @@ Show, and Generic, as their derived code all depend on the record selectors of the derived data type's constructors. -See also Note [Newtype deriving and unused constructors] in GHC.Tc.Deriv for+See also Note [Unused constructors and deriving clauses] in GHC.Tc.Deriv for another example of a similar trick. -}
compiler/GHC/Tc/Errors.hs view
@@ -1,19 +1,20 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE ParallelListComp #-} module GHC.Tc.Errors( reportUnsolved, reportAllUnsolved, warnAllUnsolved, warnDefaulting, - solverDepthErrorTcS+ -- * GHC API helper functions+ solverReportMsg_ExpectedActuals,+ solverReportInfo_ExpectedActuals ) where import GHC.Prelude@@ -28,6 +29,7 @@ import GHC.Tc.Types import GHC.Tc.Utils.Monad import GHC.Tc.Errors.Types+import GHC.Tc.Errors.Ppr import GHC.Tc.Types.Constraint import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.Env( tcInitTidyEnv )@@ -82,13 +84,11 @@ import Data.Foldable ( toList ) import Data.Functor ( (<&>) ) import Data.Function ( on )-import Data.List ( partition, mapAccumL, sort )+import Data.List ( partition, sort, sortBy ) import Data.List.NonEmpty ( NonEmpty(..), (<|) ) import qualified Data.List.NonEmpty as NE ( map, reverse )-import Data.List ( sortBy ) import Data.Ord ( comparing )-import GHC.Tc.Errors.Ppr-+import qualified Data.Semigroup as S {- ************************************************************************@@ -263,9 +263,9 @@ -- Internal functions -------------------------------------------- --- | Make a report from a single 'TcReportMsg'.-important :: ReportErrCtxt -> TcReportMsg -> SolverReport-important ctxt doc = mempty { sr_important_msgs = [ReportWithCtxt ctxt doc] }+-- | Make a report from a single 'TcSolverReportMsg'.+important :: SolverReportErrCtxt -> TcSolverReportMsg -> SolverReport+important ctxt doc = mempty { sr_important_msgs = [SolverReportWithCtxt ctxt doc] } mk_relevant_bindings :: RelevantBindings -> SolverReport mk_relevant_bindings binds = mempty { sr_supplementary = [SupplementaryBindings binds] }@@ -273,15 +273,15 @@ mk_report_hints :: [GhcHint] -> SolverReport mk_report_hints hints = mempty { sr_hints = hints } --- | Returns True <=> the ReportErrCtxt indicates that something is deferred-deferringAnyBindings :: ReportErrCtxt -> Bool+-- | Returns True <=> the SolverReportErrCtxt indicates that something is deferred+deferringAnyBindings :: SolverReportErrCtxt -> Bool -- Don't check cec_type_holes, as these don't cause bindings to be deferred deferringAnyBindings (CEC { cec_defer_type_errors = ErrorWithoutFlag , cec_expr_holes = ErrorWithoutFlag , cec_out_of_scope_holes = ErrorWithoutFlag }) = False deferringAnyBindings _ = True -maybeSwitchOffDefer :: EvBindsVar -> ReportErrCtxt -> ReportErrCtxt+maybeSwitchOffDefer :: EvBindsVar -> SolverReportErrCtxt -> SolverReportErrCtxt -- Switch off defer-type-errors inside CoEvBindsVar -- See Note [Failing equalities with no evidence bindings] maybeSwitchOffDefer evb ctxt@@ -329,7 +329,7 @@ previously suppressed. (e.g. partial-sigs/should_fail/T14584) -} -reportImplic :: ReportErrCtxt -> Implication -> TcM ()+reportImplic :: SolverReportErrCtxt -> Implication -> TcM () reportImplic ctxt implic@(Implic { ic_skols = tvs , ic_given = given , ic_wanted = wanted, ic_binds = evb@@ -357,7 +357,7 @@ warnRedundantConstraints ctxt' tcl_env info' dead_givens } where insoluble = isInsolubleStatus status- (env1, tvs') = mapAccumL tidyVarBndr (cec_tidy ctxt) $+ (env1, tvs') = tidyVarBndrs (cec_tidy ctxt) $ scopedSort tvs -- scopedSort: the ic_skols may not be in dependency order -- (see Note [Skolems in an implication] in GHC.Tc.Types.Constraint)@@ -388,15 +388,15 @@ IC_BadTelescope -> True _ -> False -warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [EvVar] -> TcM ()+warnRedundantConstraints :: SolverReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [EvVar] -> TcM () -- See Note [Tracking redundant constraints] in GHC.Tc.Solver warnRedundantConstraints ctxt env info ev_vars | null redundant_evs = return () | SigSkol user_ctxt _ _ <- info- = setLclEnv env $ -- We want to add "In the type signature for f"- -- to the error context, which is a bit tiresome+ = restoreLclEnv env $ -- We want to add "In the type signature for f"+ -- to the error context, which is a bit tiresome setSrcSpan (redundantConstraintsSpan user_ctxt) $ report_redundant_msg True @@ -429,7 +429,7 @@ improving pred -- (transSuperClasses p) does not include p = any isImprovementPred (pred : transSuperClasses pred) -reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [TcTyVar] -> TcM ()+reportBadTelescope :: SolverReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [TcTyVar] -> TcM () reportBadTelescope ctxt env (ForAllSkol telescope) skols = do { msg <- mkErrorReport env@@ -438,7 +438,7 @@ [] ; reportDiagnostic msg } where- report = ReportWithCtxt ctxt $ BadTelescope telescope skols+ report = SolverReportWithCtxt ctxt $ BadTelescope telescope skols reportBadTelescope _ _ skol_info skols = pprPanic "reportBadTelescope" (ppr skol_info $$ ppr skols)@@ -460,20 +460,73 @@ This only matters in instance declarations.. -} -reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()-reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics- , wc_holes = holes })- = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples- , text "Suppress =" <+> ppr (cec_suppress ctxt)- , text "tidy_cts =" <+> ppr tidy_cts- , text "tidy_holes = " <+> ppr tidy_holes ])+-- | Should we completely ignore this constraint in error reporting?+-- It *must* be the case that any constraint for which this returns True+-- somehow causes an error to be reported elsewhere.+-- See Note [Constraints to ignore].+ignoreConstraint :: Ct -> Bool+ignoreConstraint ct+ | AssocFamPatOrigin <- ctOrigin ct+ = True+ | otherwise+ = False +-- | Makes an error item from a constraint, calculating whether or not+-- the item should be suppressed. See Note [Wanteds rewrite Wanteds]+-- in GHC.Tc.Types.Constraint. Returns Nothing if we should just ignore+-- a constraint. See Note [Constraints to ignore].+mkErrorItem :: Ct -> TcM (Maybe ErrorItem)+mkErrorItem ct+ | ignoreConstraint ct+ = do { traceTc "Ignoring constraint:" (ppr ct)+ ; return Nothing } -- See Note [Constraints to ignore]++ | otherwise+ = do { let loc = ctLoc ct+ flav = ctFlavour ct++ ; (suppress, m_evdest) <- case ctEvidence ct of+ CtGiven {} -> return (False, Nothing)+ CtWanted { ctev_rewriters = rewriters, ctev_dest = dest }+ -> do { supp <- anyUnfilledCoercionHoles rewriters+ ; return (supp, Just dest) }++ ; let m_reason = case ct of CIrredCan { cc_reason = reason } -> Just reason+ _ -> Nothing++ ; return $ Just $ EI { ei_pred = ctPred ct+ , ei_evdest = m_evdest+ , ei_flavour = flav+ , ei_loc = loc+ , ei_m_reason = m_reason+ , ei_suppress = suppress }}++----------------------------------------------------------------+reportWanteds :: SolverReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()+reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics+ , wc_holes = holes })+ | isEmptyWC wc = traceTc "reportWanteds empty WC" empty+ | otherwise+ = do { tidy_items <- mapMaybeM mkErrorItem tidy_cts+ ; traceTc "reportWanteds 1" (vcat [ text "Simples =" <+> ppr simples+ , text "Suppress =" <+> ppr (cec_suppress ctxt)+ , text "tidy_cts =" <+> ppr tidy_cts+ , text "tidy_items =" <+> ppr tidy_items+ , text "tidy_holes =" <+> ppr tidy_holes ])++ -- This check makes sure that we aren't suppressing the only error that will+ -- actually stop compilation+ ; massert $+ null simples || -- no errors to report here+ any ignoreConstraint simples || -- one error is ignorable (is reported elsewhere)+ not (all ei_suppress tidy_items) -- not all error are suppressed+ -- First, deal with any out-of-scope errors: ; let (out_of_scope, other_holes) = partition isOutOfScopeHole tidy_holes -- don't suppress out-of-scope errors ctxt_for_scope_errs = ctxt { cec_suppress = False } ; (_, no_out_of_scope) <- askNoErrs $- reportHoles tidy_cts ctxt_for_scope_errs out_of_scope+ reportHoles tidy_items ctxt_for_scope_errs out_of_scope -- Next, deal with things that are utterly wrong -- Like Int ~ Bool (incl nullary TyCons)@@ -481,57 +534,71 @@ -- These /ones/ are not suppressed by the incoming context -- (but will be by out-of-scope errors) ; let ctxt_for_insols = ctxt { cec_suppress = not no_out_of_scope }- ; reportHoles tidy_cts ctxt_for_insols other_holes+ ; reportHoles tidy_items ctxt_for_insols other_holes -- holes never suppress - ; (ctxt1, cts1) <- tryReporters ctxt_for_insols report1 tidy_cts+ -- See Note [Suppressing confusing errors]+ ; let (suppressed_items, items0) = partition suppress tidy_items+ ; traceTc "reportWanteds suppressed:" (ppr suppressed_items)+ ; (ctxt1, items1) <- tryReporters ctxt_for_insols report1 items0 -- Now all the other constraints. We suppress errors here if -- any of the first batch failed, or if the enclosing context -- says to suppress- ; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 }- ; (_, leftovers) <- tryReporters ctxt2 report2 cts1+ ; let ctxt2 = ctxt1 { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 }+ ; (ctxt3, leftovers) <- tryReporters ctxt2 report2 items1 ; massertPpr (null leftovers) (text "The following unsolved Wanted constraints \ \have not been reported to the user:" $$ ppr leftovers) - -- All the Derived ones have been filtered out of simples- -- by the constraint solver. This is ok; we don't want- -- to report unsolved Derived goals as errors- -- See Note [Do not report derived but soluble errors]-- ; mapBagM_ (reportImplic ctxt2) implics }+ ; mapBagM_ (reportImplic ctxt2) implics -- NB ctxt2: don't suppress inner insolubles if there's only a -- wanted insoluble here; but do suppress inner insolubles -- if there's a *given* insoluble here (= inaccessible code)++ -- Only now, if there are no errors, do we report suppressed ones+ -- See Note [Suppressing confusing errors]+ -- We don't need to update the context further because of the+ -- whenNoErrs guard+ ; whenNoErrs $+ do { (_, more_leftovers) <- tryReporters ctxt3 report3 suppressed_items+ ; massertPpr (null more_leftovers) (ppr more_leftovers) } } where- env = cec_tidy ctxt+ env = cec_tidy ctxt tidy_cts = bagToList (mapBag (tidyCt env) simples) tidy_holes = bagToList (mapBag (tidyHole env) holes) + -- See Note [Suppressing confusing errors]+ suppress :: ErrorItem -> Bool+ suppress item+ | Wanted <- ei_flavour item+ = is_ww_fundep_item item+ | otherwise+ = False+ -- report1: ones that should *not* be suppressed by -- an insoluble somewhere else in the tree -- It's crucial that anything that is considered insoluble -- (see GHC.Tc.Utils.insolublWantedCt) is caught here, otherwise -- we might suppress its error message, and proceed on past -- type checking to get a Lint error later- report1 = [ ("custom_error", unblocked is_user_type_error, True, mkUserTypeErrorReporter)+ report1 = [ ("custom_error", is_user_type_error, True, mkUserTypeErrorReporter) , given_eq_spec- , ("insoluble2", unblocked utterly_wrong, True, mkGroupReporter mkEqErr)- , ("skolem eq1", unblocked very_wrong, True, mkSkolReporter)- , ("skolem eq2", unblocked skolem_eq, True, mkSkolReporter)- , ("non-tv eq", unblocked non_tv_eq, True, mkSkolReporter)+ , ("insoluble2", utterly_wrong, True, mkGroupReporter mkEqErr)+ , ("skolem eq1", very_wrong, True, mkSkolReporter)+ , ("skolem eq2", skolem_eq, True, mkSkolReporter)+ , ("non-tv eq", non_tv_eq, True, mkSkolReporter) -- The only remaining equalities are alpha ~ ty, -- where alpha is untouchable; and representational equalities -- Prefer homogeneous equalities over hetero, because the -- former might be holding up the latter. -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical- , ("Homo eqs", unblocked is_homo_equality, True, mkGroupReporter mkEqErr)- , ("Other eqs", unblocked is_equality, True, mkGroupReporter mkEqErr)- , ("Blocked eqs", is_equality, False, mkSuppressReporter mkBlockedEqErr)]+ , ("Homo eqs", is_homo_equality, True, mkGroupReporter mkEqErr)+ , ("Other eqs", is_equality, True, mkGroupReporter mkEqErr)+ ] -- report2: we suppress these if there are insolubles elsewhere in the tree report2 = [ ("Implicit params", is_ip, False, mkGroupReporter mkIPErr)@@ -539,17 +606,17 @@ , ("FixedRuntimeRep", is_FRR, False, mkGroupReporter mkFRRErr) , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) ] - -- also checks to make sure the constraint isn't HoleBlockerReason- -- See TcCanonical Note [Equalities with incompatible kinds], (4)- unblocked :: (Ct -> Pred -> Bool) -> Ct -> Pred -> Bool- unblocked _ (CIrredCan { cc_reason = HoleBlockerReason {}}) _ = False- unblocked checker ct pred = checker ct pred+ -- report3: suppressed errors should be reported as categorized by either report1+ -- or report2. Keep this in sync with the suppress function above+ report3 = [ ("wanted/wanted fundeps", is_ww_fundep, True, mkGroupReporter mkEqErr)+ ] -- rigid_nom_eq, rigid_nom_tv_eq,- is_dict, is_equality, is_ip, is_FRR, is_irred :: Ct -> Pred -> Bool+ is_dict, is_equality, is_ip, is_FRR, is_irred :: ErrorItem -> Pred -> Bool - is_given_eq ct pred- | EqPred {} <- pred = arisesFromGivens ct+ is_given_eq item pred+ | Given <- ei_flavour item+ , EqPred {} <- pred = True | otherwise = False -- I think all given residuals are equalities @@ -569,7 +636,7 @@ non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1) non_tv_eq _ _ = False - is_user_type_error ct _ = isUserTypeErrorCt ct+ is_user_type_error item _ = isUserTypeError (errorItemPred item) is_homo_equality _ (EqPred _ ty1 ty2) = tcTypeKind ty1 `tcEqType` tcTypeKind ty2 is_homo_equality _ _ = False@@ -583,8 +650,8 @@ is_ip _ (ClassPred cls _) = isIPClass cls is_ip _ _ = False - is_FRR ct (SpecialPred ConcretePrimPred _)- | FixedRuntimeRepOrigin {} <- ctOrigin ct+ is_FRR item (SpecialPred ConcretePrimPred _)+ | FixedRuntimeRepOrigin {} <- errorItemOrigin item = True is_FRR _ _ = False@@ -592,8 +659,12 @@ is_irred _ (IrredPred {}) = True is_irred _ _ = False + -- See situation (1) of Note [Suppressing confusing errors]+ is_ww_fundep item _ = is_ww_fundep_item item+ is_ww_fundep_item = isWantedWantedFunDepOrigin . errorItemOrigin+ given_eq_spec -- See Note [Given errors]- | has_gadt_match (cec_encl ctxt)+ | has_gadt_match_here = ("insoluble1a", is_given_eq, True, mkGivenErrorReporter) | otherwise = ("insoluble1b", is_given_eq, False, ignoreErrorReporter)@@ -604,6 +675,7 @@ -- #13446 is an example -- See Note [Given errors]+ has_gadt_match_here = has_gadt_match (cec_encl ctxt) has_gadt_match [] = False has_gadt_match (implic : implics) | PatSkol {} <- ic_info implic@@ -633,36 +705,119 @@ Just (tc,_) | isTypeFamilyTyCon tc -> Just tc _ -> Nothing +{- Note [Suppressing confusing errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Certain errors we might encounter are potentially confusing to users.+If there are any other errors to report, at all, we want to suppress these.++Which errors (only 1 case right now):++1) Errors which arise from the interaction of two Wanted fun-dep constraints.+ Example:++ class C a b | a -> b where+ op :: a -> b -> b++ foo _ = op True Nothing++ bar _ = op False []++ Here, we could infer+ foo :: C Bool (Maybe a) => p -> Maybe a+ bar :: C Bool [a] => p -> [a]++ (The unused arguments suppress the monomorphism restriction.) The problem+ is that these types can't both be correct, as they violate the functional+ dependency. Yet reporting an error here is awkward: we must+ non-deterministically choose either foo or bar to reject. We thus want+ to report this problem only when there is nothing else to report.+ See typecheck/should_fail/T13506 for an example of when to suppress+ the error. The case above is actually accepted, because foo and bar+ are checked separately, and thus the two fundep constraints never+ encounter each other. It is test case typecheck/should_compile/FunDepOrigin1.++ This case applies only when both fundeps are *Wanted* fundeps; when+ both are givens, the error represents unreachable code. For+ a Given/Wanted case, see #9612.++Mechanism:++We use the `suppress` function within reportWanteds to filter out these two+cases, then report all other errors. Lastly, we return to these suppressed+ones and report them only if there have been no errors so far.++Note [Constraints to ignore]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some constraints are meant only to aid the solver by unification; a failure+to solve them is not necessarily an error to report to the user. It is critical+that compilation is aborted elsewhere if there are any ignored constraints here;+they will remain unfilled, and might have been used to rewrite another constraint.++Currently, the constraints to ignore are:++1) Constraints generated in order to unify associated type instance parameters+ with class parameters. Here are two illustrative examples:++ class C (a :: k) where+ type F (b :: k)++ instance C True where+ type F a = Int++ instance C Left where+ type F (Left :: a -> Either a b) = Bool++ In the first instance, we want to infer that `a` has type Bool. So we emit+ a constraint unifying kappa (the guessed type of `a`) with Bool. All is well.++ In the second instance, we process the associated type instance only+ after fixing the quantified type variables of the class instance. We thus+ have skolems a1 and b1 such that the class instance is for (Left :: a1 -> Either a1 b1).+ Unifying a1 and b1 with a and b in the type instance will fail, but harmlessly so.+ checkConsistentFamInst checks for this, and will fail if anything has gone+ awry. Really the equality constraints emitted are just meant as an aid, not+ a requirement. This is test case T13972.++ We detect this case by looking for an origin of AssocFamPatOrigin; constraints+ with this origin are dropped entirely during error message reporting.++ If there is any trouble, checkValidFamInst bleats, aborting compilation.++-}+++ -------------------------------------------- -- Reporters -------------------------------------------- type Reporter- = ReportErrCtxt -> [Ct] -> TcM ()+ = SolverReportErrCtxt -> [ErrorItem] -> TcM () type ReporterSpec- = ( String -- Name- , Ct -> Pred -> Bool -- Pick these ones- , Bool -- True <=> suppress subsequent reporters- , Reporter) -- The reporter itself+ = ( String -- Name+ , ErrorItem -> Pred -> Bool -- Pick these ones+ , Bool -- True <=> suppress subsequent reporters+ , Reporter) -- The reporter itself mkSkolReporter :: Reporter -- Suppress duplicates with either the same LHS, or same location-mkSkolReporter ctxt cts- = mapM_ (reportGroup mkEqErr ctxt) (group cts)+-- Pre-condition: all items are equalities+mkSkolReporter ctxt items+ = mapM_ (reportGroup mkEqErr ctxt) (group items) where group [] = []- group (ct:cts) = (ct : yeses) : group noes+ group (item:items) = (item : yeses) : group noes where- (yeses, noes) = partition (group_with ct) cts+ (yeses, noes) = partition (group_with item) items - group_with ct1 ct2- | EQ <- cmp_loc ct1 ct2 = True- | eq_lhs_type ct1 ct2 = True- | otherwise = False+ group_with item1 item2+ | EQ <- cmp_loc item1 item2 = True+ | eq_lhs_type item1 item2 = True+ | otherwise = False -reportHoles :: [Ct] -- other (tidied) constraints- -> ReportErrCtxt -> [Hole] -> TcM ()-reportHoles tidy_cts ctxt holes+reportHoles :: [ErrorItem] -- other (tidied) constraints+ -> SolverReportErrCtxt -> [Hole] -> TcM ()+reportHoles tidy_items ctxt holes = do diag_opts <- initDiagOpts <$> getDynFlags let severity = diagReasonSeverity diag_opts (cec_type_holes ctxt)@@ -671,7 +826,7 @@ -- because otherwise types will be zonked and tidied many times over. (tidy_env', lcl_name_cache) <- zonkTidyTcLclEnvs (cec_tidy ctxt) (map (ctl_env . hole_loc) holes') let ctxt' = ctxt { cec_tidy = tidy_env' }- forM_ holes' $ \hole -> do { msg <- mkHoleError lcl_name_cache tidy_cts ctxt' hole+ forM_ holes' $ \hole -> do { msg <- mkHoleError lcl_name_cache tidy_items ctxt' hole ; reportDiagnostic msg } keepThisHole :: Severity -> Hole -> Bool@@ -730,42 +885,43 @@ mkUserTypeErrorReporter :: Reporter mkUserTypeErrorReporter ctxt- = mapM_ $ \ct -> do { let err = important ctxt $ mkUserTypeError ct- ; maybeReportError ctxt ct err- ; addDeferredBinding ctxt err ct }+ = mapM_ $ \item -> do { let err = important ctxt $ mkUserTypeError item+ ; maybeReportError ctxt [item] err+ ; addDeferredBinding ctxt err item } -mkUserTypeError :: Ct -> TcReportMsg-mkUserTypeError ct =- case getUserTypeErrorMsg ct of+mkUserTypeError :: ErrorItem -> TcSolverReportMsg+mkUserTypeError item =+ case getUserTypeErrorMsg (errorItemPred item) of Just msg -> UserTypeError msg- Nothing -> pprPanic "mkUserTypeError" (ppr ct)+ Nothing -> pprPanic "mkUserTypeError" (ppr item) mkGivenErrorReporter :: Reporter -- See Note [Given errors]-mkGivenErrorReporter ctxt cts- = do { (ctxt, relevant_binds, ct) <- relevantBindings True ctxt ct+mkGivenErrorReporter ctxt items+ = do { (ctxt, relevant_binds, item) <- relevantBindings True ctxt item ; let (implic:_) = cec_encl ctxt -- Always non-empty when mkGivenErrorReporter is called- ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic))+ loc' = setCtLocEnv (ei_loc item) (ic_env implic)+ item' = item { ei_loc = loc' } -- For given constraints we overwrite the env (and hence src-loc) -- with one from the immediately-enclosing implication. -- See Note [Inaccessible code] - ; (eq_err_msgs, _hints) <- mkEqErr_help ctxt ct' ty1 ty2+ ; (eq_err_msgs, _hints) <- mkEqErr_help ctxt item' ty1 ty2 -- The hints wouldn't help in this situation, so we discard them. ; let supplementary = [ SupplementaryBindings relevant_binds ]- msg = TcRnInaccessibleCode implic (NE.reverse . NE.map (ReportWithCtxt ctxt) $ eq_err_msgs)- ; msg <- mkErrorReport (ctLocEnv (ctLoc ct')) msg (Just ctxt) supplementary+ msg = TcRnInaccessibleCode implic (NE.reverse . NE.map (SolverReportWithCtxt ctxt) $ eq_err_msgs)+ ; msg <- mkErrorReport (ctLocEnv loc') msg (Just ctxt) supplementary ; reportDiagnostic msg } where- (ct : _ ) = cts -- Never empty- (ty1, ty2) = getEqPredTys (ctPred ct)+ (item : _ ) = items -- Never empty+ (ty1, ty2) = getEqPredTys (errorItemPred item) ignoreErrorReporter :: Reporter -- Discard Given errors that don't come from -- a pattern match; maybe we should warn instead?-ignoreErrorReporter ctxt cts- = do { traceTc "mkGivenErrorReporter no" (ppr cts $$ ppr (cec_encl ctxt))+ignoreErrorReporter ctxt items+ = do { traceTc "mkGivenErrorReporter no" (ppr items $$ ppr (cec_encl ctxt)) ; return () } @@ -803,59 +959,43 @@ find one, we report the insoluble Given. -} -mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM SolverReport)+mkGroupReporter :: (SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport) -- Make error message for a group -> Reporter -- Deal with lots of constraints -- Group together errors from same location, -- and report only the first (to avoid a cascade)-mkGroupReporter mk_err ctxt cts- = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)---- Like mkGroupReporter, but doesn't actually print error messages-mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM SolverReport)- -> Reporter-mkSuppressReporter mk_err ctxt cts- = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)+mkGroupReporter mk_err ctxt items+ = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc items) -eq_lhs_type :: Ct -> Ct -> Bool-eq_lhs_type ct1 ct2- = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of+eq_lhs_type :: ErrorItem -> ErrorItem -> Bool+eq_lhs_type item1 item2+ = case (classifyPredType (errorItemPred item1), classifyPredType (errorItemPred item2)) of (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) -> (eq_rel1 == eq_rel2) && (ty1 `eqType` ty2)- _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2)+ _ -> pprPanic "mkSkolReporter" (ppr item1 $$ ppr item2) -cmp_loc :: Ct -> Ct -> Ordering-cmp_loc ct1 ct2 = get ct1 `compare` get ct2+cmp_loc :: ErrorItem -> ErrorItem -> Ordering+cmp_loc item1 item2 = get item1 `compare` get item2 where- get ct = realSrcSpanStart (ctLocSpan (ctLoc ct))+ get ei = realSrcSpanStart (ctLocSpan (errorItemCtLoc ei)) -- Reduce duplication by reporting only one error from each -- /starting/ location even if the end location differs -reportGroup :: (ReportErrCtxt -> [Ct] -> TcM SolverReport) -> Reporter-reportGroup mk_err ctxt cts- | ct1 : _ <- cts =- do { err <- mk_err ctxt cts- ; traceTc "About to maybeReportErr" $- vcat [ text "Constraint:" <+> ppr cts- , text "cec_suppress =" <+> ppr (cec_suppress ctxt)- , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ]- ; maybeReportError ctxt ct1 err- -- But see Note [Always warn with -fdefer-type-errors]- ; traceTc "reportGroup" (ppr cts)- ; mapM_ (addDeferredBinding ctxt err) cts }- -- Add deferred bindings for all- -- Redundant if we are going to abort compilation,- -- but that's hard to know for sure, and if we don't- -- abort, we need bindings for all (e.g. #12156)- | otherwise = panic "empty reportGroup"---- like reportGroup, but does not actually report messages. It still adds--- -fdefer-type-errors bindings, though.-suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM SolverReport) -> Reporter-suppressGroup mk_err ctxt cts- = do { err <- mk_err ctxt cts- ; traceTc "Suppressing errors for" (ppr cts)- ; mapM_ (addDeferredBinding ctxt err) cts }+reportGroup :: (SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport) -> Reporter+reportGroup mk_err ctxt items+ = do { err <- mk_err ctxt items+ ; traceTc "About to maybeReportErr" $+ vcat [ text "Constraint:" <+> ppr items+ , text "cec_suppress =" <+> ppr (cec_suppress ctxt)+ , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ]+ ; maybeReportError ctxt items err+ -- But see Note [Always warn with -fdefer-type-errors]+ ; traceTc "reportGroup" (ppr items)+ ; mapM_ (addDeferredBinding ctxt err) items }+ -- Add deferred bindings for all+ -- Redundant if we are going to abort compilation,+ -- but that's hard to know for sure, and if we don't+ -- abort, we need bindings for all (e.g. #12156) -- See Note [No deferring for multiplicity errors] nonDeferrableOrigin :: CtOrigin -> Bool@@ -864,23 +1004,33 @@ nonDeferrableOrigin (FixedRuntimeRepOrigin {}) = True nonDeferrableOrigin _ = False -maybeReportError :: ReportErrCtxt -> Ct -> SolverReport -> TcM ()-maybeReportError ctxt ct (SolverReport { sr_important_msgs = important, sr_supplementary = supp, sr_hints = hints })- = unless (cec_suppress ctxt) $ -- Some worse error has occurred, so suppress this diagnostic- do let reason | nonDeferrableOrigin (ctOrigin ct) = ErrorWithoutFlag- | otherwise = cec_defer_type_errors ctxt+maybeReportError :: SolverReportErrCtxt+ -> [ErrorItem] -- items covered by the Report+ -> SolverReport -> TcM ()+maybeReportError ctxt items@(item1:_) (SolverReport { sr_important_msgs = important+ , sr_supplementary = supp+ , sr_hints = hints })+ = unless (cec_suppress ctxt -- Some worse error has occurred, so suppress this diagnostic+ || all ei_suppress items) $+ -- if they're all to be suppressed, report nothing+ -- if at least one is not suppressed, do report:+ -- the function that generates the error message+ -- should look for an unsuppressed error item+ do let reason | any (nonDeferrableOrigin . errorItemOrigin) items = ErrorWithoutFlag+ | otherwise = cec_defer_type_errors ctxt -- See Note [No deferring for multiplicity errors] diag = TcRnSolverReport important reason hints- msg <- mkErrorReport (ctLocEnv (ctLoc ct)) diag (Just ctxt) supp+ msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item1)) diag (Just ctxt) supp reportDiagnostic msg+maybeReportError _ _ _ = panic "maybeReportError" -addDeferredBinding :: ReportErrCtxt -> SolverReport -> Ct -> TcM ()+addDeferredBinding :: SolverReportErrCtxt -> SolverReport -> ErrorItem -> TcM () -- See Note [Deferring coercion errors to runtime]-addDeferredBinding ctxt err ct+addDeferredBinding ctxt err (EI { ei_evdest = Just dest, ei_pred = item_ty+ , ei_loc = loc })+ -- if evdest is Just, then the constraint was from a wanted | deferringAnyBindings ctxt- , CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct- -- Only add deferred bindings for Wanted constraints- = do { err_tm <- mkErrorTerm ctxt (ctLoc ct) pred err+ = do { err_tm <- mkErrorTerm ctxt loc item_ty err ; let ev_binds_var = cec_binds ctxt ; case dest of@@ -891,11 +1041,9 @@ let co_var = coHoleCoVar hole ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm ; fillCoercionHole hole (mkTcCoVarCo co_var) }}-- | otherwise -- Do not set any evidence for Given/Derived- = return ()+addDeferredBinding _ _ _ = return () -- Do not set any evidence for Given -mkErrorTerm :: ReportErrCtxt -> CtLoc -> Type -- of the error term+mkErrorTerm :: SolverReportErrCtxt -> CtLoc -> Type -- of the error term -> SolverReport -> TcM EvTerm mkErrorTerm ctxt ct_loc ty (SolverReport { sr_important_msgs = important, sr_supplementary = supp }) = do { msg <- mkErrorReport@@ -909,49 +1057,51 @@ ; return $ evDelayedError ty err_str } -tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])+tryReporters :: SolverReportErrCtxt -> [ReporterSpec] -> [ErrorItem] -> TcM (SolverReportErrCtxt, [ErrorItem]) -- Use the first reporter in the list whose predicate says True-tryReporters ctxt reporters cts- = do { let (vis_cts, invis_cts) = partition (isVisibleOrigin . ctOrigin) cts- ; traceTc "tryReporters {" (ppr vis_cts $$ ppr invis_cts)- ; (ctxt', cts') <- go ctxt reporters vis_cts invis_cts- ; traceTc "tryReporters }" (ppr cts')- ; return (ctxt', cts') }+tryReporters ctxt reporters items+ = do { let (vis_items, invis_items)+ = partition (isVisibleOrigin . errorItemOrigin) items+ ; traceTc "tryReporters {" (ppr vis_items $$ ppr invis_items)+ ; (ctxt', items') <- go ctxt reporters vis_items invis_items+ ; traceTc "tryReporters }" (ppr items')+ ; return (ctxt', items') } where- go ctxt [] vis_cts invis_cts- = return (ctxt, vis_cts ++ invis_cts)+ go ctxt [] vis_items invis_items+ = return (ctxt, vis_items ++ invis_items) - go ctxt (r : rs) vis_cts invis_cts+ go ctxt (r : rs) vis_items invis_items -- always look at *visible* Origins before invisible ones -- this is the whole point of isVisibleOrigin- = do { (ctxt', vis_cts') <- tryReporter ctxt r vis_cts- ; (ctxt'', invis_cts') <- tryReporter ctxt' r invis_cts- ; go ctxt'' rs vis_cts' invis_cts' }+ = do { (ctxt', vis_items') <- tryReporter ctxt r vis_items+ ; (ctxt'', invis_items') <- tryReporter ctxt' r invis_items+ ; go ctxt'' rs vis_items' invis_items' } -- Carry on with the rest, because we must make -- deferred bindings for them if we have -fdefer-type-errors -- But suppress their error messages -tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct])-tryReporter ctxt (str, keep_me, suppress_after, reporter) cts+tryReporter :: SolverReportErrCtxt -> ReporterSpec -> [ErrorItem] -> TcM (SolverReportErrCtxt, [ErrorItem])+tryReporter ctxt (str, keep_me, suppress_after, reporter) items | null yeses- = return (ctxt, cts)+ = return (ctxt, items) | otherwise = do { traceTc "tryReporter{ " (text str <+> ppr yeses) ; (_, no_errs) <- askNoErrs (reporter ctxt yeses)- ; let suppress_now = not no_errs && suppress_after+ ; let suppress_now = not no_errs && suppress_after -- See Note [Suppressing error messages] ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt } ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after) ; return (ctxt', nos) } where- (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts+ (yeses, nos) = partition keep items+ keep item = keep_me item (classifyPredType (errorItemPred item)) -- | Wrap an input 'TcRnMessage' with additional contextual information, -- such as relevant bindings or valid hole fits. mkErrorReport :: TcLclEnv -> TcRnMessage -- ^ The main payload of the message.- -> Maybe ReportErrCtxt+ -> Maybe SolverReportErrCtxt -- ^ The context to add, after the main diagnostic -- but before the supplementary information. -- Nothing <=> don't add any context.@@ -1065,56 +1215,6 @@ types are unlifted, the error is guaranteed to be hit before we get to the coercion. -Note [Do not report derived but soluble errors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The wc_simples include Derived constraints that have not been solved,-but are not insoluble (in that case they'd be reported by 'report1').-We do not want to report these as errors:--* Superclass constraints. If we have an unsolved [W] Ord a, we'll also have- an unsolved [D] Eq a, and we do not want to report that; it's just noise.--* Functional dependencies. For givens, consider- class C a b | a -> b- data T a where- MkT :: C a d => [d] -> T a- f :: C a b => T a -> F Int- f (MkT xs) = length xs- Then we get a [D] b~d. But there *is* a legitimate call to- f, namely f (MkT [True]) :: T Bool, in which b=d. So we should- not reject the program.-- For wanteds, something similar- data T a where- MkT :: C Int b => a -> b -> T a- g :: C Int c => c -> ()- f :: T a -> ()- f (MkT x y) = g x- Here we get [G] C Int b, [W] C Int a, hence [D] a~b.- But again f (MkT True True) is a legitimate call.--(We leave the Deriveds in wc_simple until reportErrors, so that we don't lose-derived superclasses between iterations of the solver.)--For functional dependencies, here is a real example,-stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs-- class C a b | a -> b- g :: C a b => a -> b -> ()- f :: C a b => a -> b -> ()- f xa xb =- let loop = g xa- in loop xb--We will first try to infer a type for loop, and we will succeed:- C a b' => b' -> ()-Subsequently, we will type check (loop xb) and all is good. But,-recall that we have to solve a final implication constraint:- C a b => (C a b' => .... cts from body of loop .... ))-And now we have a problem as we will generate an equality b ~ b' and fail to-solve it.-- ************************************************************************ * * Irreducible predicate errors@@ -1122,15 +1222,24 @@ ************************************************************************ -} -mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM SolverReport-mkIrredErr ctxt cts- = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1+mkIrredErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport+mkIrredErr ctxt items+ = do { (ctxt, binds_msg, item1) <- relevantBindings True ctxt item1 ; let msg = important ctxt $- CouldNotDeduce (getUserGivens ctxt) (ct1 :| others) Nothing+ CouldNotDeduce (getUserGivens ctxt) (item1 :| others) Nothing ; return $ msg `mappend` mk_relevant_bindings binds_msg } where- ct1:others = cts+ (item1:others) = final_items + filtered_items = filter (not . ei_suppress) items+ final_items | null filtered_items = items+ -- they're all suppressed; must report *something*+ -- NB: even though reportWanteds asserts that not+ -- all items are suppressed, it's possible all the+ -- irreducibles are suppressed, and so this function+ -- might get all suppressed items+ | otherwise = filtered_items+ {- Note [Constructing Hole Errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1167,7 +1276,7 @@ ---------------- -- | Constructs a new hole error, unless this is deferred. See Note [Constructing Hole Errors].-mkHoleError :: NameEnv Type -> [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope TcRnMessage)+mkHoleError :: NameEnv Type -> [ErrorItem] -> SolverReportErrCtxt -> Hole -> TcM (MsgEnvelope TcRnMessage) mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_occ = occ, hole_loc = ct_loc }) | isOutOfScopeHole hole = do { dflags <- getDynFlags@@ -1179,7 +1288,7 @@ = unknownNameSuggestions WL_Anything dflags hpt curr_mod rdr_env (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)- errs = [ReportWithCtxt ctxt (ReportHoleError hole $ OutOfScopeHole imp_errs)]+ errs = [SolverReportWithCtxt ctxt (ReportHoleError hole $ OutOfScopeHole imp_errs)] report = SolverReport errs [] hints ; maybeAddDeferredBindings ctxt hole report@@ -1213,7 +1322,7 @@ ; (grouped_skvs, other_tvs) <- zonkAndGroupSkolTvs hole_ty ; let reason | ExprHole _ <- sort = cec_expr_holes ctxt | otherwise = cec_type_holes ctxt- errs = [ReportWithCtxt ctxt $ ReportHoleError hole $ HoleError sort other_tvs grouped_skvs]+ errs = [SolverReportWithCtxt ctxt $ ReportHoleError hole $ HoleError sort other_tvs grouped_skvs] supp = [ SupplementaryBindings rel_binds , SupplementaryCts relevant_cts , SupplementaryHoleFits hole_fits ]@@ -1254,7 +1363,7 @@ -- | Adds deferred bindings (as errors). -- See Note [Adding deferred bindings].-maybeAddDeferredBindings :: ReportErrCtxt+maybeAddDeferredBindings :: SolverReportErrCtxt -> Hole -> SolverReport -> TcM ()@@ -1271,24 +1380,32 @@ writeMutVar ref err_tm _ -> pure () --- We unwrap the ReportErrCtxt here, to avoid introducing a loop in module+-- We unwrap the SolverReportErrCtxt here, to avoid introducing a loop in module -- imports-validHoleFits :: ReportErrCtxt -- ^ The context we're in, i.e. the- -- implications and the tidy environment- -> [Ct] -- ^ Unsolved simple constraints- -> Hole -- ^ The hole- -> TcM (ReportErrCtxt, ValidHoleFits)- -- ^ We return the new context- -- with a possibly updated- -- tidy environment, and- -- the valid hole fits.-validHoleFits ctxt@(CEC {cec_encl = implics- , cec_tidy = lcl_env}) simps hole- = do { (tidy_env, fits) <- findValidHoleFits lcl_env implics simps hole+validHoleFits :: SolverReportErrCtxt -- ^ The context we're in, i.e. the+ -- implications and the tidy environment+ -> [ErrorItem] -- ^ Unsolved simple constraints+ -> Hole -- ^ The hole+ -> TcM (SolverReportErrCtxt, ValidHoleFits)+ -- ^ We return the new context+ -- with a possibly updated+ -- tidy environment, and+ -- the valid hole fits.+validHoleFits ctxt@(CEC { cec_encl = implics+ , cec_tidy = lcl_env}) simps hole+ = do { (tidy_env, fits) <- findValidHoleFits lcl_env implics (map mk_wanted simps) hole ; return (ctxt {cec_tidy = tidy_env}, fits) }+ where+ mk_wanted :: ErrorItem -> CtEvidence+ mk_wanted (EI { ei_pred = pred, ei_evdest = Just dest, ei_loc = loc })+ = CtWanted { ctev_pred = pred+ , ctev_dest = dest+ , ctev_loc = loc+ , ctev_rewriters = emptyRewriterSet }+ mk_wanted item = pprPanic "validHoleFits no evdest" (ppr item) -- See Note [Constraints include ...]-givenConstraints :: ReportErrCtxt -> [(Type, RealSrcSpan)]+givenConstraints :: SolverReportErrCtxt -> [(Type, RealSrcSpan)] givenConstraints ctxt = do { implic@Implic{ ic_given = given } <- cec_encl ctxt ; constraint <- given@@ -1296,13 +1413,16 @@ ---------------- -mkIPErr :: ReportErrCtxt -> [Ct] -> TcM SolverReport-mkIPErr ctxt cts- = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1- ; let msg = important ctxt $ UnboundImplicitParams (ct1 :| others)+mkIPErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport+-- What would happen if an item is suppressed because of+-- Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint? Very unclear+-- what's best. Let's not worry about this.+mkIPErr ctxt items+ = do { (ctxt, binds_msg, item1) <- relevantBindings True ctxt item1+ ; let msg = important ctxt $ UnboundImplicitParams (item1 :| others) ; return $ msg `mappend` mk_relevant_bindings binds_msg } where- ct1:others = cts+ item1:others = items ---------------- @@ -1310,15 +1430,15 @@ -- Wanted constraints arising from representation-polymorphism checks. -- -- See Note [Reporting representation-polymorphism errors] in GHC.Tc.Types.Origin.-mkFRRErr :: ReportErrCtxt -> [Ct] -> TcM SolverReport-mkFRRErr ctxt cts+mkFRRErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport+mkFRRErr ctxt items = do { -- Zonking/tidying. ; origs <- -- Zonk/tidy the 'CtOrigin's.- zonkTidyOrigins (cec_tidy ctxt) (map ctOrigin cts)+ zonkTidyOrigins (cec_tidy ctxt) (map errorItemOrigin items) <&> -- Then remove duplicates: only retain one 'CtOrigin' per representation-polymorphic type.- (nubOrdBy (nonDetCmpType `on` (snd . frr_orig_and_type)) . snd)+ (nubOrdBy (nonDetCmpType `on` (snd . frr_orig_and_type)) . snd) -- Obtain all the errors we want to report (constraints with FixedRuntimeRep origin), -- with the corresponding types: -- ty1 :: TYPE rep1, ty2 :: TYPE rep2, ...@@ -1392,21 +1512,29 @@ -- Don't have multiple equality errors from the same location -- E.g. (Int,Bool) ~ (Bool,Int) one error will do!-mkEqErr :: ReportErrCtxt -> [Ct] -> TcM SolverReport-mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct-mkEqErr _ [] = panic "mkEqErr"+mkEqErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport+mkEqErr ctxt items+ | item:_ <- filter (not . ei_suppress) items+ = mkEqErr1 ctxt item -mkEqErr1 :: ReportErrCtxt -> Ct -> TcM SolverReport-mkEqErr1 ctxt ct -- Wanted or derived;- -- givens handled in mkGivenErrorReporter- = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct+ | item:_ <- items -- they're all suppressed. still need an error message+ -- for -fdefer-type-errors though+ = mkEqErr1 ctxt item++ | otherwise+ = panic "mkEqErr" -- guaranteed to have at least one item++mkEqErr1 :: SolverReportErrCtxt -> ErrorItem -> TcM SolverReport+mkEqErr1 ctxt item -- Wanted only+ -- givens handled in mkGivenErrorReporter+ = do { (ctxt, binds_msg, item) <- relevantBindings True ctxt item ; rdr_env <- getGlobalRdrEnv ; fam_envs <- tcGetFamInstEnvs- ; let mb_coercible_msg = case ctEqRel ct of+ ; let mb_coercible_msg = case errorItemEqRel item of NomEq -> Nothing ReprEq -> ReportCoercibleMsg <$> mkCoercibleExplanation rdr_env fam_envs ty1 ty2- ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct))- ; (last_msg :| prev_msgs, hints) <- mkEqErr_help ctxt ct ty1 ty2+ ; traceTc "mkEqErr1" (ppr item $$ pprCtOrigin (errorItemOrigin item))+ ; (last_msg :| prev_msgs, hints) <- mkEqErr_help ctxt item ty1 ty2 ; let report = foldMap (important ctxt) (reverse prev_msgs) `mappend` (important ctxt $ mkTcReportWithInfo last_msg $ maybeToList mb_coercible_msg)@@ -1414,7 +1542,7 @@ `mappend` (mk_report_hints hints) ; return report } where- (ty1, ty2) = getEqPredTys (ctPred ct)+ (ty1, ty2) = getEqPredTys (errorItemPred item) -- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint -- is left over.@@ -1458,44 +1586,43 @@ = False -- | Accumulated messages in reverse order.-type AccReportMsgs = NonEmpty TcReportMsg+type AccReportMsgs = NonEmpty TcSolverReportMsg -mkEqErr_help :: ReportErrCtxt- -> Ct+mkEqErr_help :: SolverReportErrCtxt+ -> ErrorItem -> TcType -> TcType -> TcM (AccReportMsgs, [GhcHint])-mkEqErr_help ctxt ct ty1 ty2+mkEqErr_help ctxt item ty1 ty2 | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1- = mkTyVarEqErr ctxt ct tv1 ty2+ = mkTyVarEqErr ctxt item tv1 ty2 | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2- = mkTyVarEqErr ctxt ct tv2 ty1+ = mkTyVarEqErr ctxt item tv2 ty1 | otherwise- = return (reportEqErr ctxt ct ty1 ty2 :| [], [])+ = return (reportEqErr ctxt item ty1 ty2 :| [], []) -reportEqErr :: ReportErrCtxt- -> Ct- -> TcType -> TcType -> TcReportMsg-reportEqErr ctxt ct ty1 ty2+reportEqErr :: SolverReportErrCtxt+ -> ErrorItem+ -> TcType -> TcType -> TcSolverReportMsg+reportEqErr ctxt item ty1 ty2 = mkTcReportWithInfo mismatch eqInfos where- mismatch = misMatchOrCND False ctxt ct ty1 ty2- eqInfos = eqInfoMsgs ct ty1 ty2+ mismatch = misMatchOrCND False ctxt item ty1 ty2+ eqInfos = eqInfoMsgs ty1 ty2 -mkTyVarEqErr :: ReportErrCtxt -> Ct+mkTyVarEqErr :: SolverReportErrCtxt -> ErrorItem -> TcTyVar -> TcType -> TcM (AccReportMsgs, [GhcHint]) -- tv1 and ty2 are already tidied-mkTyVarEqErr ctxt ct tv1 ty2- = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2)- ; dflags <- getDynFlags- ; mkTyVarEqErr' dflags ctxt ct tv1 ty2 }+mkTyVarEqErr ctxt item tv1 ty2+ = do { traceTc "mkTyVarEqErr" (ppr item $$ ppr tv1 $$ ppr ty2)+ ; mkTyVarEqErr' ctxt item tv1 ty2 } -mkTyVarEqErr' :: DynFlags -> ReportErrCtxt -> Ct+mkTyVarEqErr' :: SolverReportErrCtxt -> ErrorItem -> TcTyVar -> TcType -> TcM (AccReportMsgs, [GhcHint])-mkTyVarEqErr' dflags ctxt ct tv1 ty2+mkTyVarEqErr' ctxt item tv1 ty2 -- impredicativity is a simple error to understand; try it first | check_eq_result `cterHasProblem` cteImpredicative = do tyvar_eq_info <- extraTyVarEqInfo tv1 ty2 let- poly_msg = CannotUnifyWithPolytype ct tv1 ty2+ poly_msg = CannotUnifyWithPolytype item tv1 ty2 poly_msg_with_info | isSkolemTyVar tv1 = mkTcReportWithInfo poly_msg tyvar_eq_info@@ -1509,7 +1636,7 @@ | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have -- swapped in Solver.Canonical.canEqTyVarHomo || isTyVarTyVar tv1 && not (isTyVarTy ty2)- || ctEqRel ct == ReprEq+ || errorItemEqRel item == ReprEq -- The cases below don't really apply to ReprEq (except occurs check) = do tv_extra <- extraTyVarEqInfo tv1 ty2@@ -1519,7 +1646,7 @@ -- We report an "occurs check" even for a ~ F t a, where F is a type -- function; it's not insoluble (because in principle F could reduce) -- but we have certainly been unable to solve it- = let extras2 = eqInfoMsgs ct ty1 ty2+ = let extras2 = eqInfoMsgs ty1 ty2 interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $ filter isTyVar $@@ -1532,6 +1659,11 @@ in return (mkTcReportWithInfo headline_msg (extras2 ++ extras3) :| [], []) + -- This is wrinkle (4) in Note [Equalities with incompatible kinds] in+ -- GHC.Tc.Solver.Canonical+ | hasCoercionHoleTy ty2+ = return (mkBlockedEqErr item :| [], [])+ -- If the immediately-enclosing implication has 'tv' a skolem, and -- we know by now its an InferSkol kind of skolem, then presumably -- it started life as a TyVarTv, else it'd have been unified, given@@ -1548,7 +1680,7 @@ , Implic { ic_skols = skols } <- implic , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols , not (null esc_skols)- = return (SkolemEscape ct implic esc_skols :| [mismatch_msg], [])+ = return (SkolemEscape item implic esc_skols :| [mismatch_msg], []) -- Nastiest case: attempt to unify an untouchable variable -- So tv is a meta tyvar (or started that way before we@@ -1564,43 +1696,48 @@ return (mkTcReportWithInfo tclvl_extra tv_extra :| [mismatch_msg], add_sig) | otherwise- = return (reportEqErr ctxt ct (mkTyVarTy tv1) ty2 :| [], [])+ = return (reportEqErr ctxt item (mkTyVarTy tv1) ty2 :| [], []) -- This *can* happen (#6123) -- Consider an ambiguous top-level constraint (a ~ F a) -- Not an occurs check, because F is a type function. where- headline_msg = misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2- mismatch_msg = mkMismatchMsg ct ty1 ty2+ headline_msg = misMatchOrCND insoluble_occurs_check ctxt item ty1 ty2+ mismatch_msg = mkMismatchMsg item ty1 ty2 add_sig = maybeToList $ suggestAddSig ctxt ty1 ty2 ty1 = mkTyVarTy tv1 - check_eq_result = case ct of- CIrredCan { cc_reason = NonCanonicalReason result } -> result- CIrredCan { cc_reason = HoleBlockerReason {} } -> cteProblem cteHoleBlocker- _ -> checkTyVarEq dflags tv1 ty2+ check_eq_result = case ei_m_reason item of+ Just (NonCanonicalReason result) -> result+ _ -> checkTyVarEq tv1 ty2 -- in T2627b, we report an error for F (F a0) ~ a0. Note that the type -- variable is on the right, so we don't get useful info for the CIrredCan, -- and have to compute the result of checkTyVarEq here. insoluble_occurs_check = check_eq_result `cterHasProblem` cteInsolubleOccurs -eqInfoMsgs :: Ct -> TcType -> TcType -> [TcReportInfo]+eqInfoMsgs :: TcType -> TcType -> [TcSolverReportInfo] -- Report (a) ambiguity if either side is a type function application -- e.g. F a0 ~ Int -- (b) warning about injectivity if both sides are the same -- type function application F a ~ F b -- See Note [Non-injective type functions]-eqInfoMsgs ct ty1 ty2+eqInfoMsgs ty1 ty2 = catMaybes [tyfun_msg, ambig_msg] where mb_fun1 = isTyFun_maybe ty1 mb_fun2 = isTyFun_maybe ty2- (ambig_kvs, ambig_tvs) = getAmbigTkvs ct + -- if a type isn't headed by a type function, then any ambiguous+ -- variables need not be reported as such. e.g.: F a ~ t0 -> t0, where a is a skolem+ ambig_tkvs1 = maybe mempty (\_ -> ambigTkvsOfTy ty1) mb_fun1+ ambig_tkvs2 = maybe mempty (\_ -> ambigTkvsOfTy ty2) mb_fun2++ ambig_tkvs@(ambig_kvs, ambig_tvs) = ambig_tkvs1 S.<> ambig_tkvs2+ ambig_msg | isJust mb_fun1 || isJust mb_fun2 , not (null ambig_kvs && null ambig_tvs)- = Just $ Ambiguity False (ambig_kvs, ambig_tvs)+ = Just $ Ambiguity False ambig_tkvs | otherwise = Nothing @@ -1612,24 +1749,23 @@ | otherwise = Nothing -misMatchOrCND :: Bool -> ReportErrCtxt -> Ct- -> TcType -> TcType -> TcReportMsg+misMatchOrCND :: Bool -> SolverReportErrCtxt -> ErrorItem+ -> TcType -> TcType -> TcSolverReportMsg -- If oriented then ty1 is actual, ty2 is expected-misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2+misMatchOrCND insoluble_occurs_check ctxt item ty1 ty2 | insoluble_occurs_check -- See Note [Insoluble occurs check] || (isRigidTy ty1 && isRigidTy ty2)- || isGivenCt ct+ || (ei_flavour item == Given) || null givens = -- If the equality is unconditionally insoluble -- or there is no context, don't report the context- mkMismatchMsg ct ty1 ty2+ mkMismatchMsg item ty1 ty2 | otherwise- = CouldNotDeduce givens (ct :| []) (Just $ CND_Extra level ty1 ty2)+ = CouldNotDeduce givens (item :| []) (Just $ CND_Extra level ty1 ty2) where- ev = ctEvidence ct- level = ctLocTypeOrKind_maybe (ctEvLoc ev) `orElse` TypeLevel+ level = ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel givens = [ given | given <- getUserGivens ctxt, ic_given_eqs given /= NoGivenEqs ] -- Keep only UserGivens that have some equalities. -- See Note [Suppress redundant givens during error reporting]@@ -1639,9 +1775,8 @@ -- always be another unsolved wanted around, which will ordinarily suppress -- this message. But this can still be printed out with -fdefer-type-errors -- (sigh), so we must produce a message.-mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM SolverReport-mkBlockedEqErr ctxt (ct:_) = return $ important ctxt (BlockedEquality ct)-mkBlockedEqErr _ [] = panic "mkBlockedEqErr no constraints"+mkBlockedEqErr :: ErrorItem -> TcSolverReportMsg+mkBlockedEqErr item = BlockedEquality item {- Note [Suppress redundant givens during error reporting]@@ -1683,7 +1818,7 @@ in GHC.Tc.TyCl.PatSyn). -} -extraTyVarEqInfo :: TcTyVar -> TcType -> TcM [TcReportInfo]+extraTyVarEqInfo :: TcTyVar -> TcType -> TcM [TcSolverReportInfo] -- Add on extra info about skolem constants -- NB: The types themselves are already tidied extraTyVarEqInfo tv1 ty2@@ -1693,7 +1828,7 @@ Just (tv, _) -> (:[]) <$> extraTyVarInfo tv Nothing -> return [] -extraTyVarInfo :: TcTyVar -> TcM TcReportInfo+extraTyVarInfo :: TcTyVar -> TcM TcSolverReportInfo extraTyVarInfo tv = assertPpr (isTyVar tv) (ppr tv) $ case tcTyVarDetails tv of SkolemTv skol_info lvl overlaps -> do@@ -1702,7 +1837,7 @@ _ -> return $ TyVarInfo tv -suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> Maybe GhcHint+suggestAddSig :: SolverReportErrCtxt -> TcType -> TcType -> Maybe GhcHint -- See Note [Suggest adding a type signature] suggestAddSig ctxt ty1 _ty2 | bndr : bndrs <- inferred_bndrs@@ -1728,53 +1863,49 @@ = find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv ----------------------mkMismatchMsg :: Ct -> Type -> Type -> TcReportMsg-mkMismatchMsg ct ty1 ty2 =- case ctOrigin ct of+mkMismatchMsg :: ErrorItem -> Type -> Type -> TcSolverReportMsg+mkMismatchMsg item ty1 ty2 =+ case orig of TypeEqOrigin { uo_actual, uo_expected, uo_thing = mb_thing } -> mkTcReportWithInfo (TypeEqMismatch { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds- , teq_mismatch_ct = ct- , teq_mismatch_ty1 = ty1- , teq_mismatch_ty2 = ty2+ , teq_mismatch_item = item+ , teq_mismatch_ty1 = ty1+ , teq_mismatch_ty2 = ty2 , teq_mismatch_actual = uo_actual , teq_mismatch_expected = uo_expected , teq_mismatch_what = mb_thing}) extras KindEqOrigin cty1 cty2 sub_o mb_sub_t_or_k ->- mkTcReportWithInfo (Mismatch False ct ty1 ty2)+ mkTcReportWithInfo (Mismatch False item ty1 ty2) (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k : extras) _ -> mkTcReportWithInfo- (Mismatch False ct ty1 ty2)+ (Mismatch False item ty1 ty2) extras where- orig = ctOrigin ct+ orig = errorItemOrigin item extras = sameOccExtras ty2 ty1 ppr_explicit_kinds = shouldPprWithExplicitKinds ty1 ty2 orig --- | Whether to prints explicit kinds (with @-fprint-explicit-kinds@)+-- | Whether to print explicit kinds (with @-fprint-explicit-kinds@) -- in an 'SDoc' when a type mismatch occurs to due invisible kind arguments. -- -- This function first checks to see if the 'CtOrigin' argument is a--- 'TypeEqOrigin', and if so, uses the expected/actual types from that to--- check for a kind mismatch (as these types typically have more surrounding--- types and are likelier to be able to glean information about whether a--- mismatch occurred in an invisible argument position or not). If the--- 'CtOrigin' is not a 'TypeEqOrigin', fall back on the actual mismatched types--- themselves.+-- 'TypeEqOrigin'. If so, it first checks whether the equality is a visible+-- equality; if it's not, definitely print the kinds. Even if the equality is+-- a visible equality, check the expected/actual types to see if the types+-- have equal visible components. If the 'CtOrigin' is+-- not a 'TypeEqOrigin', fall back on the actual mismatched types themselves. shouldPprWithExplicitKinds :: Type -> Type -> CtOrigin -> Bool-shouldPprWithExplicitKinds ty1 ty2 ct- = tcEqTypeVis act_ty exp_ty- -- True when the visible bit of the types look the same,- -- so we want to show the kinds in the displayed type.- where- (act_ty, exp_ty) = case ct of- TypeEqOrigin { uo_actual = act- , uo_expected = exp } -> (act, exp)- _ -> (ty1, ty2)+shouldPprWithExplicitKinds _ty1 _ty2 (TypeEqOrigin { uo_actual = act+ , uo_expected = exp+ , uo_visible = vis })+ | not vis = True -- See tests T15870, T16204c+ | otherwise = tcEqTypeVis act exp -- See tests T9171, T9144.+shouldPprWithExplicitKinds ty1 ty2 _ct+ = tcEqTypeVis ty1 ty2 {- Note [Insoluble occurs check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1794,7 +1925,7 @@ want to be as draconian with them.) -} -sameOccExtras :: TcType -> TcType -> [TcReportInfo]+sameOccExtras :: TcType -> TcType -> [TcSolverReportInfo] -- See Note [Disambiguating (X ~ X) errors] sameOccExtras ty1 ty2 | Just (tc1, _) <- tcSplitTyConApp_maybe ty1@@ -1876,41 +2007,46 @@ ************************************************************************ -} -mkDictErr :: HasDebugCallStack => ReportErrCtxt -> [Ct] -> TcM SolverReport-mkDictErr ctxt cts- = assert (not (null cts)) $+mkDictErr :: HasDebugCallStack => SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport+mkDictErr ctxt orig_items+ = assert (not (null items)) $ do { inst_envs <- tcGetInstEnvs- ; let min_cts = elim_superclasses cts- lookups = map (lookup_cls_inst inst_envs) min_cts- (no_inst_cts, overlap_cts) = partition is_no_inst lookups+ ; let min_items = elim_superclasses items+ lookups = map (lookup_cls_inst inst_envs) min_items+ (no_inst_items, overlap_items) = partition is_no_inst lookups -- Report definite no-instance errors, -- or (iff there are none) overlap errors -- But we report only one of them (hence 'head') because they all -- have the same source-location origin, to try avoid a cascade -- of error from one location- ; err <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))+ ; err <- mk_dict_err ctxt (head (no_inst_items ++ overlap_items)) ; return $ important ctxt err } where+ filtered_items = filter (not . ei_suppress) orig_items+ items | null filtered_items = orig_items -- all suppressed, but must report+ -- something for -fdefer-type-errors+ | otherwise = filtered_items -- common case+ no_givens = null (getUserGivens ctxt) - is_no_inst (ct, (matches, unifiers, _))+ is_no_inst (item, (matches, unifiers, _)) = no_givens && null matches- && (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct))+ && (nullUnifiers unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfTypeList (errorItemPred item))) - lookup_cls_inst inst_envs ct- = (ct, lookupInstEnv True inst_envs clas tys)+ lookup_cls_inst inst_envs item+ = (item, lookupInstEnv True inst_envs clas tys) where- (clas, tys) = getClassPredTys (ctPred ct)+ (clas, tys) = getClassPredTys (errorItemPred item) -- When simplifying [W] Ord (Set a), we need -- [W] Eq a, [W] Ord a -- but we really only want to report the latter- elim_superclasses cts = mkMinimalBySCs ctPred cts+ elim_superclasses items = mkMinimalBySCs errorItemPred items --- [Note: mk_dict_err]+-- Note [mk_dict_err] -- ~~~~~~~~~~~~~~~~~~~ -- Different dictionary error messages are reported depending on the number of -- matches and unifiers:@@ -1921,16 +2057,16 @@ -- - One match, one or more unifiers: report "Overlapping instances for", show the -- matching and unifying instances, and say "The choice depends on the instantion of ..., -- and the result of evaluating ...".-mk_dict_err :: HasCallStack => ReportErrCtxt -> (Ct, ClsInstLookupResult)- -> TcM TcReportMsg+mk_dict_err :: HasCallStack => SolverReportErrCtxt -> (ErrorItem, ClsInstLookupResult)+ -> TcM TcSolverReportMsg -- Report an overlap error if this class constraint results -- from an overlap (returning Left clas), otherwise return (Right pred)-mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped))+mk_dict_err ctxt (item, (matches, unifiers, unsafe_overlapped)) | null matches -- No matches but perhaps several unifiers- = do { (_, rel_binds, ct) <- relevantBindings True ctxt ct+ = do { (_, rel_binds, item) <- relevantBindings True ctxt item ; candidate_insts <- get_candidate_instances ; (imp_errs, field_suggestions) <- record_field_suggestions- ; return (cannot_resolve_msg ct candidate_insts rel_binds imp_errs field_suggestions) }+ ; return (cannot_resolve_msg item candidate_insts rel_binds imp_errs field_suggestions) } | null unsafe_overlapped -- Some matches => overlap errors = return $ overlap_msg@@ -1938,8 +2074,8 @@ | otherwise = return $ safe_haskell_msg where- orig = ctOrigin ct- pred = ctPred ct+ orig = errorItemOrigin item+ pred = errorItemPred item (clas, tys) = getClassPredTys pred ispecs = [ispec | (ispec, _) <- matches] unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped]@@ -1986,21 +2122,22 @@ HasFieldOrigin name -> Just (mkVarOccFS name) _ -> Nothing - cannot_resolve_msg :: Ct -> [ClsInst] -> RelevantBindings -> [ImportError] -> [GhcHint] -> TcReportMsg- cannot_resolve_msg ct candidate_insts binds imp_errs field_suggestions- = CannotResolveInstance ct unifiers candidate_insts imp_errs field_suggestions binds+ cannot_resolve_msg :: ErrorItem -> [ClsInst] -> RelevantBindings+ -> [ImportError] -> [GhcHint] -> TcSolverReportMsg+ cannot_resolve_msg item candidate_insts binds imp_errs field_suggestions+ = CannotResolveInstance item (getPotentialUnifiers unifiers) candidate_insts imp_errs field_suggestions binds -- Overlap errors.- overlap_msg, safe_haskell_msg :: TcReportMsg+ overlap_msg, safe_haskell_msg :: TcSolverReportMsg -- Normal overlap error overlap_msg- = assert (not (null matches)) $ OverlappingInstances ct ispecs unifiers+ = assert (not (null matches)) $ OverlappingInstances item ispecs (getPotentialUnifiers unifiers) -- Overlap error because of Safe Haskell (first -- match should be the most specific match) safe_haskell_msg = assert (matches `lengthIs` 1 && not (null unsafe_ispecs)) $- UnsafeOverlap ct ispecs unsafe_ispecs+ UnsafeOverlap item ispecs unsafe_ispecs {- Note [Report candidate instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2082,14 +2219,6 @@ Which makes it clearer that the culprit is the mismatch between `k2` and `k20`. -} -getAmbigTkvs :: Ct -> ([Var],[Var])-getAmbigTkvs ct- = partition (`elemVarSet` dep_tkv_set) ambig_tkvs- where- tkvs = tyCoVarsOfCtList ct- ambig_tkvs = filter isAmbiguousTyVar tkvs- dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs)- ----------------------- -- relevantBindings looks at the value environment and finds values whose -- types mention any of the offending type variables. It has to be@@ -2101,11 +2230,11 @@ relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering -- See #8191- -> ReportErrCtxt -> Ct- -> TcM (ReportErrCtxt, RelevantBindings, Ct)+ -> SolverReportErrCtxt -> ErrorItem+ -> TcM (SolverReportErrCtxt, RelevantBindings, ErrorItem) -- Also returns the zonked and tidied CtOrigin of the constraint-relevantBindings want_filtering ctxt ct- = do { traceTc "relevantBindings" (ppr ct)+relevantBindings want_filtering ctxt item+ = do { traceTc "relevantBindings" (ppr item) ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc) -- For *kind* errors, report the relevant bindings of the@@ -2113,19 +2242,19 @@ ; let extra_tvs = case tidy_orig of KindEqOrigin t1 t2 _ _ -> tyCoVarsOfTypes [t1,t2] _ -> emptyVarSet- ct_fvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs+ ct_fvs = tyCoVarsOfType (errorItemPred item) `unionVarSet` extra_tvs - -- Put a zonked, tidied CtOrigin into the Ct+ -- Put a zonked, tidied CtOrigin into the ErrorItem loc' = setCtLocOrigin loc tidy_orig- ct' = setCtLoc ct loc'+ item' = item { ei_loc = loc' } ; (env2, lcl_name_cache) <- zonkTidyTcLclEnvs env1 [lcl_env] ; relev_bds <- relevant_bindings want_filtering lcl_env lcl_name_cache ct_fvs ; let ctxt' = ctxt { cec_tidy = env2 }- ; return (ctxt', relev_bds, ct') }+ ; return (ctxt', relev_bds, item') } where- loc = ctLoc ct+ loc = errorItemCtLoc item lcl_env = ctLocEnv loc -- slightly more general version, to work also with holes@@ -2218,9 +2347,12 @@ warnDefaulting the_tv wanteds@(ct:_) default_ty = do { warn_default <- woptM Opt_WarnTypeDefaults ; env0 <- tcInitTidyEnv- ; let tidy_env = tidyFreeTyCoVars env0 $- tyCoVarsOfCtsList (listToBag wanteds)- tidy_wanteds = map (tidyCt tidy_env) wanteds+ -- don't want to report all the superclass constraints, which+ -- add unhelpful clutter+ ; let filtered = filter (not . isWantedSuperclassOrigin . ctOrigin) wanteds+ tidy_env = tidyFreeTyCoVars env0 $+ tyCoVarsOfCtsList (listToBag filtered)+ tidy_wanteds = map (tidyCt tidy_env) filtered tidy_tv = lookupVarEnv (snd tidy_env) the_tv diag = TcRnWarnDefaulting tidy_wanteds tidy_tv default_ty loc = ctLoc ct@@ -2232,32 +2364,46 @@ We want to give a reasonably helpful error message for ambiguity arising from *runtime* skolems in the debugger. These are created by in GHC.Runtime.Heap.Inspect.zonkRTTIType.+-} -************************************************************************+{-********************************************************************** * *- Error from the canonicaliser- These ones are called *during* constraint simplification+ GHC API helper functions * *-************************************************************************--}+**********************************************************************-} -solverDepthErrorTcS :: CtLoc -> TcType -> TcM a-solverDepthErrorTcS loc ty- = setCtLocM loc $- do { ty <- zonkTcType ty- ; env0 <- tcInitTidyEnv- ; let tidy_env = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty)- tidy_ty = tidyType tidy_env ty- msg = TcRnUnknownMessage $ mkPlainError noHints $- vcat [ text "Reduction stack overflow; size =" <+> ppr depth- , hang (text "When simplifying the following type:")- 2 (ppr tidy_ty)- , note ]- ; failWithTcM (tidy_env, msg) }- where- depth = ctLocDepth loc- note = vcat- [ text "Use -freduction-depth=0 to disable this check"- , text "(any upper bound you could choose might fail unpredictably with"- , text " minor updates to GHC, so disabling the check is recommended if"- , text " you're sure that type checking should terminate)" ]+-- | If the 'TcSolverReportMsg' is a type mismatch between+-- an actual and an expected type, return the actual and expected types+-- (in that order).+--+-- Prefer using this over manually inspecting the 'TcSolverReportMsg' datatype+-- if you just want this information, as the datatype itself is subject to change+-- across GHC versions.+solverReportMsg_ExpectedActuals :: TcSolverReportMsg -> [(Type, Type)]+solverReportMsg_ExpectedActuals+ = \case+ TcReportWithInfo msg infos ->+ solverReportMsg_ExpectedActuals msg+ ++ (solverReportInfo_ExpectedActuals =<< toList infos)+ Mismatch { mismatch_ty1 = exp, mismatch_ty2 = act } ->+ [(exp, act)]+ KindMismatch { kmismatch_expected = exp, kmismatch_actual = act } ->+ [(exp, act)]+ TypeEqMismatch { teq_mismatch_expected = exp, teq_mismatch_actual = act } ->+ [(exp,act)]+ _ -> []++-- | Retrieves all @"expected"/"actual"@ messages from a 'TcSolverReportInfo'.+--+-- Prefer using this over inspecting the 'TcSolverReportInfo' datatype if+-- you just need this information, as the datatype itself is subject to change+-- across GHC versions.+solverReportInfo_ExpectedActuals :: TcSolverReportInfo -> [(Type, Type)]+solverReportInfo_ExpectedActuals+ = \case+ ExpectedActual { ea_expected = exp, ea_actual = act } ->+ [(exp, act)]+ ExpectedActualAfterTySynExpansion+ { ea_expanded_expected = exp, ea_expanded_actual = act } ->+ [(exp, act)]+ _ -> []
compiler/GHC/Tc/Errors/Hole.hs view
@@ -18,7 +18,7 @@ , getHoleFitDispConfig , HoleFitDispConfig (..) , HoleFitSortingAlg (..)- , relevantCts+ , relevantCtEvidence , zonkSubs , sortHoleFitsByGraph@@ -68,7 +68,8 @@ import Data.Graph ( graphFromEdges, topSort ) -import GHC.Tc.Solver ( simplifyTopWanteds, runTcSDerivedsEarlyAbort )+import GHC.Tc.Solver ( simplifyTopWanteds )+import GHC.Tc.Solver.Monad ( runTcSEarlyAbort ) import GHC.Tc.Utils.Unify ( tcSubTypeSigma ) import GHC.HsToCore.Docs ( extractDocs )@@ -189,7 +190,7 @@ Given = $dShow_a1pc :: Show a_a1pa[sk:2] Wanted = WC {wc_simple =- [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CDictCan(psc))}+ [W] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CDictCan(psc))} Binds = EvBindsVar<a1pi> Needed inner = [] Needed outer = []@@ -205,7 +206,7 @@ `tcCheckHoleFit`, the call to `tcSubType` will end up unifying the meta type variable `a0_a1pd[tau:2] := a_a1pa[sk:2]`. By wrapping the wanted constraints needed by tcSubType_NC and the relevant constraints (see Note [Relevant-Constraints] for more details) in the nested implications, we can pass the+constraints] for more details) in the nested implications, we can pass the information in the givens along to the simplifier. For our example, we end up needing to check whether the following constraints are soluble. @@ -218,7 +219,7 @@ Given = $dShow_a1pc :: Show a_a1pa[sk:2] Wanted = WC {wc_simple =- [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)}+ [W] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)} Binds = EvBindsVar<a1pl> Needed inner = [] Needed outer = []@@ -361,7 +362,7 @@ Here, the hole is given type a0_a1kv[tau:1]. Then, the emitted constraint is: - [WD] $dShow_a1kw {0}:: Show a0_a1kv[tau:1] (CNonCanonical)+ [W] $dShow_a1kw {0}:: Show a0_a1kv[tau:1] (CNonCanonical) However, when there are multiple holes, we need to be more careful. As an example, Let's take a look at the following code:@@ -373,8 +374,8 @@ _b :: a1_a1po[tau:2]. Then, the simple constraints passed to findValidHoleFits are: - [[WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical),- [WD] $dShow_a1pp {0}:: Show a1_a1po[tau:2] (CNonCanonical)]+ [[W] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical),+ [W] $dShow_a1pp {0}:: Show a1_a1po[tau:2] (CNonCanonical)] When we are looking for a match for the hole `_a`, we filter the simple constraints to the "Relevant constraints", by throwing out any constraints@@ -402,9 +403,9 @@ example, if `hole_ty = Int` and `ty = Foldable t => (a -> Bool) -> t a -> Bool`, we'd have `(a_a1pa[sk:1] -> Bool) -> t_t2jk[sk:1] a_a1pa[sk:1] -> Bool ~# Int` from the coercion, as well as `Foldable t_t2jk[sk:1]`. By adding a flag to-`TcSEnv` and adding a `runTcSDerivedsEarlyAbort`, we can fail as soon as we hit+`TcSEnv` and adding a `runTcSEarlyAbort`, we can fail as soon as we hit an insoluble constraint. Since we don't need the result in the case that it-fails, a boolean `False` (i.e. "it didn't work" from `runTcSDerivedsEarlyAbort`)+fails, a boolean `False` (i.e. "it didn't work" from `runTcSEarlyAbort`) is sufficient. We also check whether the type of the hole is an immutable type variable (i.e.@@ -552,7 +553,7 @@ -- See Note [Valid hole fits include ...] findValidHoleFits :: TidyEnv -- ^ The tidy_env for zonking -> [Implication] -- ^ Enclosing implications for givens- -> [Ct]+ -> [CtEvidence] -- ^ The unsolved simple constraints in the implication for -- the hole. -> Hole@@ -569,7 +570,7 @@ ; let findVLimit = if sortingAlg > HFSNoSorting then Nothing else maxVSubs refLevel = refLevelHoleFits dflags hole = TypedHole { th_relevant_cts =- listToBag (relevantCts hole_ty simples)+ listToBag (relevantCtEvidence hole_ty simples) , th_implics = implics , th_hole = Just h } (candidatePlugins, fitPlugins) =@@ -690,21 +691,20 @@ findValidHoleFits env _ _ _ = return (env, noValidHoleFits) -- See Note [Relevant constraints]-relevantCts :: Type -> [Ct] -> [Ct]-relevantCts hole_ty simples = if isEmptyVarSet (fvVarSet hole_fvs) then []- else filter isRelevant simples- where ctFreeVarSet :: Ct -> VarSet- ctFreeVarSet = fvVarSet . tyCoFVsOfType . ctPred- hole_fvs = tyCoFVsOfType hole_ty+relevantCtEvidence :: Type -> [CtEvidence] -> [CtEvidence]+relevantCtEvidence hole_ty simples+ = if isEmptyVarSet (fvVarSet hole_fvs)+ then []+ else filter isRelevant simples+ where hole_fvs = tyCoFVsOfType hole_ty hole_fv_set = fvVarSet hole_fvs- anyFVMentioned :: Ct -> Bool- anyFVMentioned ct = ctFreeVarSet ct `intersectsVarSet` hole_fv_set -- We filter out those constraints that have no variables (since -- they won't be solved by finding a type for the type variable -- representing the hole) and also other holes, since we're not -- trying to find hole fits for many holes at once.- isRelevant ct = not (isEmptyVarSet (ctFreeVarSet ct))- && anyFVMentioned ct+ isRelevant ctev = not (isEmptyVarSet fvs) &&+ (fvs `intersectsVarSet` hole_fv_set)+ where fvs = tyCoVarsOfCtEv ctev -- We zonk the hole fits so that the output aligns with the rest -- of the typed hole error message output.@@ -962,7 +962,7 @@ -- imp is the innermost implication (imp:_) -> return (ic_tclvl imp) ; (wrap, wanted) <- setTcLevel innermost_lvl $ captureConstraints $- tcSubTypeSigma (ExprSigCtxt NoRRC) ty hole_ty+ tcSubTypeSigma orig (ExprSigCtxt NoRRC) ty hole_ty ; traceTc "Checking hole fit {" empty ; traceTc "wanteds are: " $ ppr wanted ; if isEmptyWC wanted && isEmptyBag th_relevant_cts@@ -971,26 +971,28 @@ else do { fresh_binds <- newTcEvBinds -- The relevant constraints may contain HoleDests, so we must -- take care to clone them as well (to avoid #15370).- ; cloned_relevants <- mapBagM cloneWanted th_relevant_cts+ ; cloned_relevants <- mapBagM cloneWantedCtEv th_relevant_cts -- We wrap the WC in the nested implications, for details, see -- Note [Checking hole fits] ; let wrapInImpls cts = foldl (flip (setWCAndBinds fresh_binds)) cts th_implics- final_wc = wrapInImpls $ addSimples wanted cloned_relevants+ final_wc = wrapInImpls $ addSimples wanted $+ mapBag mkNonCanonical cloned_relevants -- We add the cloned relevants to the wanteds generated -- by the call to tcSubType_NC, for details, see -- Note [Relevant constraints]. There's no need to clone -- the wanteds, because they are freshly generated by the -- call to`tcSubtype_NC`. ; traceTc "final_wc is: " $ ppr final_wc- -- See Note [Speeding up valid-hole fits]- ; (rem, _) <- tryTc $ runTcSDerivedsEarlyAbort $ simplifyTopWanteds final_wc+ -- See Note [Speeding up valid hole-fits]+ ; (rem, _) <- tryTc $ runTcSEarlyAbort $ simplifyTopWanteds final_wc ; traceTc "}" empty- ; return (any isSolvedWC rem, wrap)- } }- where- setWCAndBinds :: EvBindsVar -- Fresh ev binds var.- -> Implication -- The implication to put WC in.- -> WantedConstraints -- The WC constraints to put implic.- -> WantedConstraints -- The new constraints.- setWCAndBinds binds imp wc- = mkImplicWC $ unitBag $ imp { ic_wanted = wc , ic_binds = binds }+ ; return (any isSolvedWC rem, wrap) } }+ where+ orig = ExprHoleOrigin (hole_occ <$> th_hole)++ setWCAndBinds :: EvBindsVar -- Fresh ev binds var.+ -> Implication -- The implication to put WC in.+ -> WantedConstraints -- The WC constraints to put implic.+ -> WantedConstraints -- The new constraints.+ setWCAndBinds binds imp wc+ = mkImplicWC $ unitBag $ imp { ic_wanted = wc , ic_binds = binds }
compiler/GHC/Tc/Errors/Hole.hs-boot view
@@ -7,18 +7,18 @@ import GHC.Types.Var ( Id ) import GHC.Tc.Errors.Types ( HoleFitDispConfig, ValidHoleFits ) import GHC.Tc.Types ( TcM )-import GHC.Tc.Types.Constraint ( Ct, CtLoc, Hole, Implication )+import GHC.Tc.Types.Constraint ( CtEvidence, CtLoc, Hole, Implication ) import GHC.Utils.Outputable ( SDoc ) import GHC.Types.Var.Env ( TidyEnv ) import GHC.Tc.Errors.Hole.FitTypes ( HoleFit, TypedHole, HoleFitCandidate )-import GHC.Tc.Utils.TcType ( TcType, TcSigmaType, Type, TcTyVar )+import GHC.Tc.Utils.TcType ( TcType, TcSigmaType, TcTyVar ) import GHC.Tc.Types.Evidence ( HsWrapper ) import GHC.Utils.FV ( FV ) import Data.Bool ( Bool ) import Data.Maybe ( Maybe ) import Data.Int ( Int ) -findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Hole+findValidHoleFits :: TidyEnv -> [Implication] -> [CtEvidence] -> Hole -> TcM (TidyEnv, ValidHoleFits) tcCheckHoleFit :: TypedHole -> TcSigmaType -> TcSigmaType@@ -37,7 +37,6 @@ getHoleFitSortingAlg :: TcM HoleFitSortingAlg getHoleFitDispConfig :: TcM HoleFitDispConfig -relevantCts :: Type -> [Ct] -> [Ct] zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit]) sortHoleFitsBySize :: [HoleFit] -> TcM [HoleFit] sortHoleFitsByGraph :: [HoleFit] -> TcM [HoleFit]
compiler/GHC/Tc/Gen/App.hs view
@@ -165,18 +165,19 @@ "application chain"? See Fig 2, of the QL paper: "A quick look at impredicativity" (ICFP'20). Here's the syntax: -app :: head- | app expr -- HsApp: ordinary application- | app @type -- HsTypeApp: VTA- | expr `head` expr -- OpApp: infix applications- | ( app ) -- HsPar: parens- | {-# PRAGMA #-} app -- HsPragE: pragmas+app ::= head+ | app expr -- HsApp: ordinary application+ | app @type -- HsTypeApp: VTA+ | expr `head` expr -- OpApp: infix applications+ | ( app ) -- HsPar: parens+ | {-# PRAGMA #-} app -- HsPragE: pragmas -head ::= f -- HsVar: variables- | fld -- HsRecSel: record field selectors- | (expr :: ty) -- ExprWithTySig: expr with user type sig- | lit -- HsOverLit: overloaded literals- | other_expr -- Other expressions+head ::= f -- HsVar: variables+ | fld -- HsRecSel: record field selectors+ | (expr :: ty) -- ExprWithTySig: expr with user type sig+ | lit -- HsOverLit: overloaded literals+ | $([| head |]) -- HsSpliceE+HsSpliced+HsSplicedExpr: untyped TH expression splices+ | other_expr -- Other expressions When tcExpr sees something that starts an application chain (namely, any of the constructors in 'app' or 'head'), it invokes tcApp to@@ -193,7 +194,7 @@ we can't get a polytype from them. Left and right sections (e.g. (x +) and (+ x)) are not yet supported.-Probably left sections (x +) would be esay to add, since x is the+Probably left sections (x +) would be easy to add, since x is the first arg of (+); but right sections are not so easy. For symmetry reasons I've left both unchanged, in GHC.Tc.Gen.Expr. @@ -205,6 +206,16 @@ instantiate that (forall b. b) impredicatively! And that only happens in tcApp. +We also wish to typecheck application chains with untyped Template Haskell+splices in the head, such as this example from #21038:+ data Foo = MkFoo (forall a. a -> a)+ f = $([| MkFoo |]) $ \x -> x+This should typecheck just as if the TH splice was never in the way—that is,+just as if the user had written `MkFoo $ \x -> x`. We could conceivably have+a case for typed TH expression splices too, but it wouldn't be useful in+practice, since the types of typed TH expressions aren't allowed to have+polymorphic types, such as the type of MkFoo.+ Note [tcApp: typechecking applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ tcApp implements the APP-Downarrow/Uparrow rule of@@ -547,8 +558,8 @@ nb_applied_val_args :: Int nb_applied_val_args = countVisAndInvisValArgs applied_args - arg_tys :: [TyCoBinder]- arg_tys = fst $ splitPiTys app_res_rho+ arg_tys :: [(Type,AnonArgFlag)]+ arg_tys = getRuntimeArgTys app_res_rho -- We do not need to zonk app_res_rho first, because the number of arrows -- in the (possibly instantiated) inferred type of the function will -- be at least the arity of the function.@@ -558,11 +569,11 @@ traceTc "tcApp remainingValArgs check_thing" (debug_msg thing arity) go (nb_applied_vis_val_args + 1) (nb_applied_val_args + 1) arg_tys where- go :: Int -- ^ visible value argument index- -- (only used to report the argument position in error messages)- -> Int -- ^ value argument index+ go :: Int -- ^ visible value argument index, starting from 1+ -- only used to report the argument position in error messages+ -> Int -- ^ value argument index, starting from 1 -- used to count up to the arity to ensure we don't check too many argument types- -> [TyCoBinder]+ -> [(Type, AnonArgFlag)] -- ^ run-time argument types -> TcM () go _ i_val _ | i_val > arity@@ -571,15 +582,13 @@ -- Should never happen: it would mean that the arity is higher -- than the number of arguments apparent from the type = pprPanic "hasFixedRuntimeRep_remainingValArgs" (debug_msg thing arity)- go i_visval !i_val (Anon af (Scaled _ arg_ty) : tys)+ go i_visval !i_val ((arg_ty, af) : tys) = case af of InvisArg -> go i_visval (i_val + 1) tys VisArg -> do _concrete_ev <- hasFixedRuntimeRep (mk_frr_orig i_visval) arg_ty go (i_visval + 1) (i_val + 1) tys- go i_visval i_val (_: tys)- = go i_visval i_val tys -- A message containing all the relevant info, in case this functions -- needs to be debugged again at some point.@@ -589,7 +598,6 @@ [ text "thing =" <+> ppr thing , text "arity =" <+> ppr arity , text "applied_args =" <+> ppr applied_args- , text "nb_applied_vis_val_args =" <+> ppr nb_applied_vis_val_args , text "nb_applied_val_args =" <+> ppr nb_applied_val_args , text "arg_tys =" <+> ppr arg_tys ]
compiler/GHC/Tc/Gen/Arrow.hs view
@@ -432,7 +432,7 @@ -- NB: The rec_ids for the recursive things -- already scope over this part. This binding may shadow -- some of them with polymorphic things with the same Name- -- (see note [RecStmt] in GHC.Hs.Expr)+ -- (see Note [RecStmt] in GHC.Hs.Expr) ; let rec_ids = takeList rec_names tup_ids ; later_ids <- tcLookupLocalIds later_names
compiler/GHC/Tc/Gen/Bind.hs view
@@ -41,6 +41,8 @@ import GHC.Tc.Utils.Unify import GHC.Tc.Solver import GHC.Tc.Types.Evidence+import GHC.Tc.Types.Constraint+import GHC.Core.Predicate import GHC.Tc.Gen.HsType import GHC.Tc.Gen.Pat import GHC.Tc.Utils.TcMType@@ -48,6 +50,7 @@ import GHC.Core.Multiplicity import GHC.Core.FamInstEnv( normaliseType ) import GHC.Tc.Instance.Family( tcGetFamInstEnvs )+import GHC.Core.Class ( Class ) import GHC.Tc.Utils.TcType import GHC.Core.Type (mkStrLitTy, tidyOpenType, mkCastTy) import GHC.Builtin.Types ( mkBoxedTupleTy )@@ -250,48 +253,36 @@ ; (given_ips, ip_binds') <- mapAndUnzipM (wrapLocSndMA (tc_ip_bind ipClass)) ip_binds - -- If the binding binds ?x = E, we must now- -- discharge any ?x constraints in expr_lie- -- See Note [Implicit parameter untouchables]+ -- Add all the IP bindings as givens for the body of the 'let' ; (ev_binds, result) <- checkConstraints (IPSkol ips) [] given_ips thing_inside ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) } where- ips = [ip | (L _ (IPBind _ (Left (L _ ip)) _)) <- ip_binds]+ ips = [ip | (L _ (IPBind _ (L _ ip) _)) <- ip_binds] -- I wonder if we should do these one at a time -- Consider ?x = 4 -- ?y = ?x + 1- tc_ip_bind ipClass (IPBind _ (Left (L _ ip)) expr)+ tc_ip_bind :: Class -> IPBind GhcRn -> TcM (DictId, IPBind GhcTc)+ tc_ip_bind ipClass (IPBind _ l_name@(L _ ip) expr) = do { ty <- newOpenFlexiTyVarTy ; let p = mkStrLitTy $ hsIPNameFS ip ; ip_id <- newDict ipClass [ p, ty ] ; expr' <- tcCheckMonoExpr expr ty- ; let d = toDict ipClass p ty `fmap` expr'- ; return (ip_id, (IPBind noAnn (Right ip_id) d)) }- tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind"+ ; let d = mapLoc (toDict ipClass p ty) expr'+ ; return (ip_id, (IPBind ip_id l_name d)) } -- Coerces a `t` into a dictionary for `IP "x" t`. -- co : t -> IP "x" t+ toDict :: Class -- IP class+ -> Type -- type-level string for name of IP+ -> Type -- type of IP+ -> HsExpr GhcTc -- def'n of IP variable+ -> HsExpr GhcTc -- dictionary for IP toDict ipClass x ty = mkHsWrap $ mkWpCastR $ wrapIP $ mkClassPred ipClass [x,ty] -{- Note [Implicit parameter untouchables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We add the type variables in the types of the implicit parameters-as untouchables, not so much because we really must not unify them,-but rather because we otherwise end up with constraints like this- Num alpha, Implic { wanted = alpha ~ Int }-The constraint solver solves alpha~Int by unification, but then-doesn't float that solved constraint out (it's not an unsolved-wanted). Result disaster: the (Num alpha) is again solved, this-time by defaulting. No no no.--However [Oct 10] this is all handled automatically by the-untouchable-range idea.--}- tcValBinds :: TopLevelFlag -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM thing@@ -726,13 +717,20 @@ ; mapM_ (checkOverloadedSig mono) sigs ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)- ; (qtvs, givens, ev_binds, insoluble)- <- simplifyInfer tclvl infer_mode sigs name_taus wanted+ ; ((qtvs, givens, ev_binds, insoluble), residual)+ <- captureConstraints $ simplifyInfer tclvl infer_mode sigs name_taus wanted ; let inferred_theta = map evVarPred givens ; exports <- checkNoErrs $- mapM (mkExport prag_fn insoluble qtvs inferred_theta) mono_infos+ mapM (mkExport prag_fn residual insoluble qtvs inferred_theta) mono_infos + -- NB: *after* the checkNoErrs call above. This ensures that we don't get an error+ -- cascade in case mkExport runs into trouble. In particular, this avoids duplicate+ -- errors when a partial type signature cannot be quantified in chooseInferredQuantifiers.+ -- See Note [Quantification and partial signatures] in GHC.Tc.Solver, Wrinkle 4.+ -- Tested in partial-sigs/should_fail/NamedWilcardExplicitForall.+ ; emitConstraints residual+ ; loc <- getSrcSpanM ; let poly_ids = map abe_poly exports abs_bind = L (noAnnSrcSpan loc) $@@ -748,6 +746,7 @@ -------------- mkExport :: TcPragEnv+ -> WantedConstraints -- residual constraints, already emitted (for errors only) -> Bool -- True <=> there was an insoluble type error -- when typechecking the bindings -> [TyVar] -> TcThetaType -- Both already zonked@@ -766,12 +765,12 @@ -- Pre-condition: the qtvs and theta are already zonked -mkExport prag_fn insoluble qtvs theta- mono_info@(MBI { mbi_poly_name = poly_name- , mbi_sig = mb_sig- , mbi_mono_id = mono_id })+mkExport prag_fn residual insoluble qtvs theta+ (MBI { mbi_poly_name = poly_name+ , mbi_sig = mb_sig+ , mbi_mono_id = mono_id }) = do { mono_ty <- zonkTcType (idType mono_id)- ; poly_id <- mkInferredPolyId insoluble qtvs theta poly_name mb_sig mono_ty+ ; poly_id <- mkInferredPolyId residual insoluble qtvs theta poly_name mb_sig mono_ty -- NB: poly_id has a zonked type ; poly_id <- addInlinePrags poly_id prag_sigs@@ -793,14 +792,21 @@ then return idHsWrapper -- Fast path; also avoids complaint when we infer -- an ambiguous type and have AllowAmbiguousType -- e..g infer x :: forall a. F a -> Int- else addErrCtxtM (mk_impedance_match_msg mono_info sel_poly_ty poly_ty) $- tcSubTypeSigma sig_ctxt sel_poly_ty poly_ty+ else tcSubTypeSigma GhcBug20076+ sig_ctxt sel_poly_ty poly_ty+ -- as Note [Impedance matching] explains, this should never fail,+ -- and thus we'll never see an error message. It *may* do+ -- instantiation, but no message will ever be printed to the+ -- user, and so we use Shouldn'tHappenOrigin.+ -- Actually, there is a bug here: #20076. So we tell the user+ -- that they hit the bug. Once #20076 is fixed, change this+ -- back to Shouldn'tHappenOrigin. ; localSigWarn poly_id mb_sig ; return (ABE { abe_ext = noExtField , abe_wrap = wrap- -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)+ -- abe_wrap :: (forall qtvs. theta => mono_ty) ~ idType poly_id , abe_poly = poly_id , abe_mono = mono_id , abe_prags = SpecPrags spec_prags }) }@@ -808,12 +814,13 @@ prag_sigs = lookupPragEnv prag_fn poly_name sig_ctxt = InfSigCtxt poly_name -mkInferredPolyId :: Bool -- True <=> there was an insoluble error when+mkInferredPolyId :: WantedConstraints -- the residual constraints, already emitted+ -> Bool -- True <=> there was an insoluble error when -- checking the binding group for this Id -> [TyVar] -> TcThetaType -> Name -> Maybe TcIdSigInst -> TcType -> TcM TcId-mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty+mkInferredPolyId residual insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty | Just (TISI { sig_inst_sig = sig }) <- mb_sig_inst , CompleteSig { sig_bndr = poly_id } <- sig = return poly_id@@ -833,7 +840,7 @@ -- We can discard the coercion _co, because we'll reconstruct -- it in the call to tcSubType below - ; (binders, theta') <- chooseInferredQuantifiers inferred_theta+ ; (binders, theta') <- chooseInferredQuantifiers residual inferred_theta (tyCoVarsOfType mono_ty') qtvs mb_sig_inst ; let inferred_poly_ty = mkInvisForAllTys binders (mkPhiTy theta' mono_ty')@@ -851,14 +858,16 @@ ; return (mkLocalId poly_name Many inferred_poly_ty) } -chooseInferredQuantifiers :: TcThetaType -- inferred+chooseInferredQuantifiers :: WantedConstraints -- residual constraints+ -> TcThetaType -- inferred -> TcTyVarSet -- tvs free in tau type -> [TcTyVar] -- inferred quantified tvs -> Maybe TcIdSigInst -> TcM ([InvisTVBinder], TcThetaType)-chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing+chooseInferredQuantifiers _residual inferred_theta tau_tvs qtvs Nothing = -- No type signature (partial or complete) for this binder, do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs)+ -- See Note [growThetaTyVars vs closeWrtFunDeps] in GHC.Tc.Solver -- Include kind variables! #7916 my_theta = pickCapturedPreds free_tvs inferred_theta binders = [ mkTyVarBinder InferredSpec tv@@ -866,11 +875,11 @@ , tv `elemVarSet` free_tvs ] ; return (binders, my_theta) } -chooseInferredQuantifiers inferred_theta tau_tvs qtvs- (Just (TISI { sig_inst_sig = sig -- Always PartialSig- , sig_inst_wcx = wcx- , sig_inst_theta = annotated_theta- , sig_inst_skols = annotated_tvs }))+chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs+ (Just (TISI { sig_inst_sig = sig@(PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty })+ , sig_inst_wcx = wcx+ , sig_inst_theta = annotated_theta+ , sig_inst_skols = annotated_tvs })) = -- Choose quantifiers for a partial type signature do { let (psig_qtv_nms, psig_qtv_bndrs) = unzip annotated_tvs ; psig_qtv_bndrs <- mapM zonkInvisTVBinder psig_qtv_bndrs@@ -888,8 +897,8 @@ -- signature is not actually quantified. How can that happen? -- See Note [Quantification and partial signatures] Wrinkle 4 -- in GHC.Tc.Solver- ; mapM_ report_mono_sig_tv_err [ n | (n,tv) <- psig_qtv_prs- , not (tv `elem` qtvs) ]+ ; mapM_ report_mono_sig_tv_err [ pr | pr@(_,tv) <- psig_qtv_prs+ , not (tv `elem` qtvs) ] ; annotated_theta <- zonkTcTypes annotated_theta ; (free_tvs, my_theta) <- choose_psig_context psig_qtv_set annotated_theta wcx@@ -905,16 +914,20 @@ ; return (final_qtvs, my_theta) } where report_dup_tyvar_tv_err (n1,n2)- | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig = addErrTc (TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty)- | otherwise -- Can't happen; by now we know it's a partial sig- = pprPanic "report_tyvar_tv_err" (ppr sig) - report_mono_sig_tv_err n- | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig- = addErrTc (TcRnPartialTypeSigBadQuantifier n fn_name hs_ty)- | otherwise -- Can't happen; by now we know it's a partial sig- = pprPanic "report_mono_sig_tv_err" (ppr sig)+ report_mono_sig_tv_err (n,tv)+ = addErrTc (TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty)+ where+ m_unif_ty = listToMaybe+ [ rhs+ -- recall that residuals are always implications+ | residual_implic <- bagToList $ wc_impl residual+ , residual_ct <- bagToList $ wc_simple (ic_wanted residual_implic)+ , let residual_pred = ctPred residual_ct+ , Just (Nominal, lhs, rhs) <- [ getEqPredTys_maybe residual_pred ]+ , Just lhs_tv <- [ tcGetTyVar_maybe lhs ]+ , lhs_tv == tv ] choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType -> TcM (VarSet, TcThetaType)@@ -925,7 +938,8 @@ choose_psig_context psig_qtvs annotated_theta (Just wc_var_ty) = do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs)- -- growThetaVars just like the no-type-sig case+ -- growThetaTyVars just like the no-type-sig case+ -- See Note [growThetaTyVars vs closeWrtFunDeps] in GHC.Tc.Solver -- Omitting this caused #12844 seed_tvs = tyCoVarsOfTypes annotated_theta -- These are put there `unionVarSet` tau_tvs -- by the user@@ -961,25 +975,8 @@ -- Hack alert! See GHC.Tc.Gen.HsType: -- Note [Extra-constraint holes in partial type signatures] -mk_impedance_match_msg :: MonoBindInfo- -> TcType -> TcType- -> TidyEnv -> TcM (TidyEnv, SDoc)--- This is a rare but rather awkward error messages-mk_impedance_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig })- inf_ty sig_ty tidy_env- = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env inf_ty- ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty- ; let msg = vcat [ text "When checking that the inferred type"- , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty- , text "is as general as its" <+> what <+> text "signature"- , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ]- ; return (tidy_env2, msg) }- where- what = case mb_sig of- Nothing -> text "inferred"- Just sig | isPartialSig sig -> text "(partial)"- | otherwise -> empty-+chooseInferredQuantifiers _ _ _ _ (Just (TISI { sig_inst_sig = sig@(CompleteSig {}) }))+ = pprPanic "chooseInferredQuantifiers" (ppr sig) mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) mk_inf_msg poly_name poly_ty tidy_env@@ -988,7 +985,6 @@ , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ] ; return (tidy_env1, msg) } - -- | Warn the user about polymorphic local binders that lack type signatures. localSigWarn :: Id -> Maybe TcIdSigInst -> TcM () localSigWarn id mb_sig@@ -1103,7 +1099,6 @@ or multi-parameter type classes - an inferred type that includes unboxed tuples - Note [Impedance matching] ~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -1128,8 +1123,8 @@ tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool) tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono) - f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f- g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g+ f a d1 d2 = case tuple a Any d1 d2 of (f_mono, g_mono) -> f_mono+ g b = case tuple Integer b dEqInteger dNumInteger of (f_mono,g_mono) -> g_mono Suppose the shared quantified tyvars are qtvs and constraints theta. Then we want to check that@@ -1138,13 +1133,10 @@ Notice that the impedance matcher may do defaulting. See #7173. -It also cleverly does an ambiguity check; for example, rejecting- f :: F a -> F a-where F is a non-injective type function.--}-+If we've gotten the constraints right during inference (and we assume we have),+this sub-type check should never fail. It's not really a check -- it's more of+a procedure to produce the right wrapper. -{- Note [SPECIALISE pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~ There is no point in a SPECIALISE pragma for a non-overloaded function:
compiler/GHC/Tc/Gen/Export.hs view
@@ -573,7 +573,7 @@ -- | Given a resolved name in the children export list and a parent. Decide -- whether we are allowed to export the child with the parent. -- Invariant: gre_par == NoParent--- See note [Typing Pattern Synonym Exports]+-- See Note [Typing Pattern Synonym Exports] checkPatSynParent :: Name -- ^ Alleged parent type constructor -- User wrote T( P, Q ) -> Parent -- The parent of P we discovered@@ -612,7 +612,7 @@ -> TcM () handle_pat_syn doc ty_con pat_syn - -- 2. See note [Types of TyCon]+ -- 2. See Note [Types of TyCon] | not $ isTyConWithSrcDataCons ty_con = addErrCtxt doc $ failWithTc TcRnPatSynBundledWithNonDataCon
compiler/GHC/Tc/Gen/Expr.hs view
@@ -52,7 +52,6 @@ import GHC.Tc.Gen.Arrow import GHC.Tc.Gen.Match import GHC.Tc.Gen.HsType-import GHC.Tc.Gen.Pat import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType as TcType@@ -685,7 +684,7 @@ not (isRecordSelector sel_id), let fld_name = idName sel_id ] ; unless (null bad_guys) (sequence bad_guys >> failM)- -- See note [Mixed Record Selectors]+ -- See Note [Mixed Record Selectors] ; let (data_sels, pat_syn_sels) = partition isDataConRecordSelector sel_ids ; massert (all isPatSynRecordSelector pat_syn_sels)@@ -1399,7 +1398,7 @@ -- (so the desugarer knows the type of local binder to make) ; return (Just (L loc (FieldOcc field_id lbl), rhs')) } | otherwise- = do { addErrTc (badFieldCon con_like field_lbl)+ = do { addErrTc (badFieldConErr (getName con_like) field_lbl) ; return Nothing } where field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)
compiler/GHC/Tc/Gen/Head.hs view
@@ -450,6 +450,8 @@ ExprWithTySig _ e hs_ty -> add_head_ctxt fun args $ Just <$> tcExprWithSig e hs_ty HsOverLit _ lit -> Just <$> tcInferOverLit lit+ HsSpliceE _ (HsSpliced _ _ (HsSplicedExpr e))+ -> tcInferAppHead_maybe e args _ -> return Nothing add_head_ctxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a@@ -605,13 +607,14 @@ = ApplyMR | otherwise = NoRestrictions- ; (qtvs, givens, ev_binds, _)- <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted+ ; ((qtvs, givens, ev_binds, _), residual)+ <- captureConstraints $ simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted+ ; emitConstraints residual ; tau <- zonkTcType tau ; let inferred_theta = map evVarPred givens tau_tvs = tyCoVarsOfType tau- ; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta+ ; (binders, my_theta) <- chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs (Just sig_inst) ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau my_sigma = mkInvisForAllTys binders (mkPhiTy my_theta tau)@@ -619,7 +622,7 @@ then return idHsWrapper -- Fast path; also avoids complaint when we infer -- an ambiguous type and have AllowAmbiguousType -- e..g infer x :: forall a. F a -> Int- else tcSubTypeSigma (ExprSigCtxt NoRRC) inferred_sigma my_sigma+ else tcSubTypeSigma ExprSigOrigin (ExprSigCtxt NoRRC) inferred_sigma my_sigma ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma) ; let poly_wrap = wrap
compiler/GHC/Tc/Gen/HsType.hs view
@@ -109,7 +109,6 @@ import GHC.Core.DataCon import GHC.Core.Class import GHC.Types.Name--- import GHC.Types.Name.Set import GHC.Types.Var.Env import GHC.Builtin.Types import GHC.Types.Basic@@ -1177,7 +1176,7 @@ -- Pass on the mode from the type, to any wildcards -- in kind signatures on the forall'd variables -- e.g. f :: _ -> Int -> forall (a :: _). blah- -- Why exp_kind? See Note [Body kind of HsForAllTy]+ -- Why exp_kind? See Note [Body kind of a HsForAllTy] -- Do not kind-generalise here! See Note [Kind generalisation] @@ -2232,10 +2231,20 @@ HM_VTA -> False HM_TyAppPat -> False -tcAnonWildCardOcc _ mode ty _--- mode_holes is Nothing. Should not happen, because renamer--- should already have rejected holes in unexpected places- = pprPanic "tcWildCardOcc" (ppr mode $$ ppr ty)+tcAnonWildCardOcc is_extra _ _ _+-- mode_holes is Nothing. This means we have an anonymous wildcard+-- in an unexpected place. The renamer rejects these wildcards in 'checkAnonWildcard',+-- but it is possible for a wildcard to be introduced by a Template Haskell splice,+-- as per #15433. To account for this, we throw a generic catch-all error message.+ = failWith $ TcRnIllegalWildcardInType Nothing reason Nothing+ where+ reason =+ case is_extra of+ YesExtraConstraint ->+ ExtraConstraintWildcardNotAllowed+ SoleExtraConstraintWildcardNotAllowed+ NoExtraConstraint ->+ WildcardsNotAllowedAtAll {- Note [Wildcard names] ~~~~~~~~~~~~~~~~~~~~~~~~@@ -2362,7 +2371,7 @@ (HsQTvs { hsq_ext = kv_ns , hsq_explicit = hs_tvs }) kc_res_ki -- CUSK case- -- See note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl+ -- See Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl = addTyConFlavCtxt name flav $ do { skol_info <- mkSkolemInfo skol_info_anon ; (tclvl, wanted, (scoped_kvs, (tc_tvs, res_kind)))@@ -2452,7 +2461,7 @@ (HsQTvs { hsq_ext = kv_ns , hsq_explicit = hs_tvs }) kc_res_ki -- No standalane kind signature and no CUSK.- -- See note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl+ -- See Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl = addTyConFlavCtxt name flav $ do { (scoped_kvs, (tc_tvs, res_kind)) -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar?@@ -3149,7 +3158,7 @@ , sm_tvtv = SMDSkolemTv skol_info }) skol_info -- Do not clone the outer binders- -- See Note [Cloning for type variable binder] under "must not"+ -- See Note [Cloning for type variable binders] under "must not" tcOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed => SkolemMode -> SkolemInfo
compiler/GHC/Tc/Gen/Pat.hs view
@@ -21,7 +21,6 @@ , tcCheckPat, tcCheckPat_O, tcInferPat , tcPats , addDataConStupidTheta- , badFieldCon , polyPatSig ) where@@ -325,7 +324,7 @@ setErrCtxt err_ctxt $ loop penv args -- setErrCtxt: restore context before doing the next pattern- -- See note [Nesting] above+ -- See Note [Nesting] above ; return (p':ps', res) } @@ -919,7 +918,7 @@ ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX skol_info tenv1 ex_tvs -- Get location from monad, not from ex_tvs -- This freshens: See Note [Freshen existentials]- -- Why "super"? See Note [Binding when lookup up instances]+ -- Why "super"? See Note [Binding when looking up instances] -- in GHC.Core.InstEnv. ; let arg_tys' = substScaledTys tenv arg_tys@@ -1190,8 +1189,8 @@ these unifications. The *only* thing the unification does is to side-effect those unification variables, so that we know what type x and y stand for; and cause an error if the equality- is not soluble. It's a bit like a Derived constraint arising- from a functional dependency.+ is not soluble. It's a bit like a constraint arising+ from a functional dependency, where we don't use the evidence. * Exactly the same works for existential arguments data T where@@ -1282,7 +1281,7 @@ -- f (R { foo = (a,b) }) = a+b -- If foo isn't one of R's fields, we don't want to crash when -- typechecking the "a+b".- [] -> failWith (badFieldCon con_like lbl)+ [] -> failWith (badFieldConErr (getName con_like) lbl) -- The normal case, when the field comes from the right constructor (pat_ty : extras) -> do@@ -1488,12 +1487,6 @@ where has_existentials :: Bool has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs--badFieldCon :: ConLike -> FieldLabelString -> TcRnMessage-badFieldCon con field- = TcRnUnknownMessage $ mkPlainError noHints $- hsep [text "Constructor" <+> quotes (ppr con),- text "does not have field", quotes (ppr field)] polyPatSig :: TcType -> SDoc polyPatSig sig_ty
compiler/GHC/Tc/Gen/Rule.hs view
@@ -15,6 +15,7 @@ import GHC.Tc.Types import GHC.Tc.Utils.Monad import GHC.Tc.Solver+import GHC.Tc.Solver.Monad ( runTcS ) import GHC.Tc.Types.Constraint import GHC.Core.Predicate import GHC.Tc.Types.Origin@@ -396,20 +397,24 @@ -- NB: This consumes all simple constraints on the LHS, but not -- any LHS implication constraints. simplifyRule name tc_lvl lhs_wanted rhs_wanted- = do {- -- Note [The SimplifyRule Plan] step 1- -- First solve the LHS and *then* solve the RHS- -- Crucially, this performs unifications- -- Why clone? See Note [Simplify cloned constraints]- ; lhs_clone <- cloneWC lhs_wanted- ; rhs_clone <- cloneWC rhs_wanted- ; setTcLevel tc_lvl $- runTcSDeriveds $- do { _ <- solveWanteds lhs_clone- ; _ <- solveWanteds rhs_clone- -- Why do them separately?- -- See Note [Solve order for RULES]- ; return () }+ = do { setTcLevel tc_lvl $+ do { -- Note [The SimplifyRule Plan] step 1+ -- First solve the LHS and *then* solve the RHS+ -- Crucially, this performs unifications+ -- Why clone? See Note [Simplify cloned constraints]+ -- This must be in the bumped TcLevel because cloneWC creates+ -- metavariables for Concrete# constraints. See Note [The Concrete mechanism]+ -- in GHC.Tc.Utils.Concrete+ ; lhs_clone <- cloneWC lhs_wanted+ ; rhs_clone <- cloneWC rhs_wanted+ ; discardResult $+ runTcS $+ do {+ ; _ <- solveWanteds lhs_clone+ ; _ <- solveWanteds rhs_clone+ -- Why do them separately?+ -- See Note [Solve order for RULES]+ ; return () }} -- Note [The SimplifyRule Plan] step 2 ; lhs_wanted <- zonkWC lhs_wanted
compiler/GHC/Tc/Gen/Sig.hs view
@@ -409,7 +409,7 @@ ; skol_info <- mkSkolemInfo (DataConSkol name) ; (tclvl, wanted, (outer_bndrs, (ex_bndrs, (req, prov, body_ty)))) <- pushLevelAndSolveEqualitiesX "tcPatSynSig" $- -- See Note [solveEqualities in tcPatSynSig]+ -- See Note [Report unsolved equalities in tcPatSynSig] tcOuterTKBndrs skol_info hs_outer_bndrs $ tcExplicitTKBndrs skol_info ex_hs_tvbndrs $ do { req <- tcHsContext hs_req
compiler/GHC/Tc/Gen/Splice.hs view
@@ -83,7 +83,6 @@ import GHC.Rename.Splice( traceSplice, SpliceInfo(..)) import GHC.Rename.Expr import GHC.Rename.Env-import GHC.Rename.Utils ( HsDocContext(..) ) import GHC.Rename.Fixity ( lookupFixityRn_help ) import GHC.Rename.HsType @@ -1011,13 +1010,12 @@ -- Compile and link it; might fail if linking fails ; src_span <- getSrcSpanM- ; mnwib <- getMnwib ; traceTc "About to run (desugared)" (ppr ds_expr) ; either_hval <- tryM $ liftIO $- GHC.Driver.Main.hscCompileCoreExpr hsc_env (src_span, Just mnwib) ds_expr+ GHC.Driver.Main.hscCompileCoreExpr hsc_env src_span ds_expr ; case either_hval of { Left exn -> fail_with_exn "compile and link" exn ;- Right hval -> do+ Right (hval, needed_mods, needed_pkgs) -> do { -- Coerce it to Q t, and run it @@ -1031,6 +1029,7 @@ -- -- See Note [Exceptions in TH] let expr_span = getLocA expr+ ; recordThNeededRuntimeDeps needed_mods needed_pkgs ; either_tval <- tryAllM $ setSrcSpan expr_span $ -- Set the span so that qLocation can -- see where this splice is@@ -1553,7 +1552,7 @@ QFail str -> fail str {- Note [TH recover with -fexternal-interpreter]-+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Recover is slightly tricky to implement. The meaning of "recover a b" is@@ -1715,7 +1714,7 @@ -> do { inst_envs <- tcGetInstEnvs ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys ; traceTc "reifyInstances'1" (ppr matches)- ; return $ Left (cls, map fst matches ++ unifies) }+ ; return $ Left (cls, map fst matches ++ getPotentialUnifiers unifies) } | isOpenFamilyTyCon tc -> do { inst_envs <- tcGetFamInstEnvs ; let matches = lookupFamInstEnv inst_envs tc tys
compiler/GHC/Tc/Instance/Class.hs view
@@ -172,12 +172,12 @@ ; case (matches, unify, safeHaskFail) of -- Nothing matches- ([], [], _)+ ([], NoUnifiers, _) -> do { traceTc "matchClass not matching" (ppr pred) ; return NoInstance } -- A single match (& no safe haskell failure)- ([(ispec, inst_tys)], [], False)+ ([(ispec, inst_tys)], NoUnifiers, False) | short_cut_solver -- Called from the short-cut solver , isOverlappable ispec -- If the instance has OVERLAPPABLE or OVERLAPS or INCOHERENT
compiler/GHC/Tc/Instance/Family.hs view
@@ -700,7 +700,7 @@ checkForConflicts inst_envs fam_inst = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst ; traceTc "checkForConflicts" $- vcat [ ppr (map fim_instance conflicts)+ vcat [ ppr conflicts , ppr fam_inst -- , ppr inst_envs ]@@ -991,20 +991,18 @@ buildInjectivityError mkErr fam_tc branches = ( coAxBranchSpan (NE.head branches), mkErr fam_tc branches ) -reportConflictInstErr :: FamInst -> [FamInstMatch] -> TcRn ()+reportConflictInstErr :: FamInst -> [FamInst] -> TcRn () reportConflictInstErr _ [] = return () -- No conflicts-reportConflictInstErr fam_inst (match1 : _)- | FamInstMatch { fim_instance = conf_inst } <- match1- , let sorted = NE.sortBy (SrcLoc.leftmost_smallest `on` getSpan) (fam_inst NE.:| [conf_inst])- fi1 = NE.head sorted- span = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1))- = setSrcSpan span $ addErr $ TcRnConflictingFamInstDecls sorted- where- getSpan = getSrcSpan . famInstAxiom+reportConflictInstErr fam_inst (conf_inst : _) = -- The sortBy just arranges that instances are displayed in order -- of source location, which reduced wobbling in error messages, -- and is better for users+ let sorted = NE.sortBy (SrcLoc.leftmost_smallest `on` getSpan) (fam_inst NE.:| [conf_inst])+ fi1 = NE.head sorted+ span = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1))+ getSpan = getSrcSpan . famInstAxiom+ in setSrcSpan span $ addErr $ TcRnConflictingFamInstDecls sorted tcGetFamInstEnvs :: TcM FamInstEnvs -- Gets both the external-package inst-env
compiler/GHC/Tc/Instance/FunDeps.hs view
@@ -5,7 +5,7 @@ -} -+{-# LANGUAGE DeriveFunctor #-} -- | Functional dependencies --@@ -18,6 +18,7 @@ , checkInstCoverage , checkFunDeps , pprFundeps+ , instFD, closeWrtFunDeps ) where @@ -43,6 +44,7 @@ import GHC.Utils.Error( Validity'(..), Validity, allValid ) import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain ( assert ) import GHC.Data.Pair ( Pair(..) ) import Data.List ( nubBy )@@ -118,6 +120,7 @@ , fd_pred1 :: PredType -- The FunDepEqn arose from , fd_pred2 :: PredType -- combining these two constraints , fd_loc :: loc }+ deriving Functor {- Given a bunch of predicates that must hold, such as@@ -227,11 +230,12 @@ where (cls_tvs, cls_fds) = classTvsFds cls instances = classInstances inst_env cls- rough_tcs = roughMatchTcs tys+ rough_tcs = RM_KnownTc (className cls) : roughMatchTcs tys pred = mkClassPred cls tys + improveClsFD :: [TyVar] -> FunDep TyVar -- One functional dependency from the class -> ClsInst -- An instance template -> [Type] -> [RoughMatchTc] -- Arguments of this (C tys) predicate@@ -349,7 +353,7 @@ For the coverage condition, we check (normal) fv(t2) `subset` fv(t1)- (liberal) fv(t2) `subset` oclose(fv(t1), theta)+ (liberal) fv(t2) `subset` closeWrtFunDeps(fv(t1), theta) The liberal version ensures the self-consistency of the instance, but it does not guarantee termination. Example:@@ -362,7 +366,7 @@ instance Mul a b c => Mul a [b] [c] where x .*. v = map (x.*.) v In the third instance, it's not the case that fv([c]) `subset` fv(a,[b]).-But it is the case that fv([c]) `subset` oclose( theta, fv(a,[b]) )+But it is the case that fv([c]) `subset` closeWrtFunDeps( theta, fv(a,[b]) ) But it is a mistake to accept the instance because then this defn: f = \ b x y -> if b then x .*. [y] else y@@ -374,7 +378,7 @@ -> Class -> [PredType] -> [Type] -> Validity -- "be_liberal" flag says whether to use "liberal" coverage of--- See Note [Coverage Condition] below+-- See Note [Coverage condition] below -- -- Return values -- Nothing => no problems@@ -395,7 +399,7 @@ undetermined_tvs | be_liberal = liberal_undet_tvs | otherwise = conserv_undet_tvs - closed_ls_tvs = oclose theta ls_tvs+ closed_ls_tvs = closeWrtFunDeps theta ls_tvs liberal_undet_tvs = (`minusVarSet` closed_ls_tvs) <$> rs_tvs conserv_undet_tvs = (`minusVarSet` ls_tvs) <$> rs_tvs @@ -406,7 +410,7 @@ vcat [ -- text "ls_tvs" <+> ppr ls_tvs -- , text "closed ls_tvs" <+> ppr (closeOverKinds ls_tvs) -- , text "theta" <+> ppr theta- -- , text "oclose" <+> ppr (oclose theta (closeOverKinds ls_tvs))+ -- , text "closeWrtFunDeps" <+> ppr (closeWrtFunDeps theta (closeOverKinds ls_tvs)) -- , text "rs_tvs" <+> ppr rs_tvs sep [ text "The" <+> ppWhen be_liberal (text "liberal")@@ -465,17 +469,17 @@ we get {l,k,xs} -> b * Note the 'k'!! We must call closeOverKinds on the seed set- ls_tvs = {l,r,xs}, BEFORE doing oclose, else the {l,k,xs}->b+ ls_tvs = {l,r,xs}, BEFORE doing closeWrtFunDeps, else the {l,k,xs}->b fundep won't fire. This was the reason for #10564. - * So starting from seeds {l,r,xs,k} we do oclose to get+ * So starting from seeds {l,r,xs,k} we do closeWrtFunDeps to get first {l,r,xs,k,b}, via the HMemberM constraint, and then {l,r,xs,k,b,v}, via the HasFieldM1 constraint. * And that fixes v. However, we must closeOverKinds whenever augmenting the seed set-in oclose! Consider #10109:+in closeWrtFunDeps! Consider #10109: data Succ a -- Succ :: forall k. k -> * class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab@@ -491,25 +495,27 @@ Bottom line: * closeOverKinds on initial seeds (done automatically by tyCoVarsOfTypes in checkInstCoverage)- * and closeOverKinds whenever extending those seeds (in oclose)+ * and closeOverKinds whenever extending those seeds (in closeWrtFunDeps) Note [The liberal coverage condition] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-(oclose preds tvs) closes the set of type variables tvs,+(closeWrtFunDeps preds tvs) closes the set of type variables tvs, wrt functional dependencies in preds. The result is a superset of the argument set. For example, if we have class C a b | a->b where ... then- oclose [C (x,y) z, C (x,p) q] {x,y} = {x,y,z}+ closeWrtFunDeps [C (x,y) z, C (x,p) q] {x,y} = {x,y,z} because if we know x and y then that fixes z. We also use equality predicates in the predicates; if we have an assumption `t1 ~ t2`, then we use the fact that if we know `t1` we also know `t2` and the other way.- eg oclose [C (x,y) z, a ~ x] {a,y} = {a,y,z,x}+ eg closeWrtFunDeps [C (x,y) z, a ~ x] {a,y} = {a,y,z,x} -oclose is used (only) when checking the coverage condition for-an instance declaration+closeWrtFunDeps is used+ - when checking the coverage condition for an instance declaration+ - when determining which tyvars are unquantifiable during generalization, in+ GHC.Tc.Solver.decideMonoTyVars. Note [Equality superclasses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -520,10 +526,10 @@ * (a ~~ b) is a superclass of (a ~ b) * (a ~# b) is a superclass of (a ~~ b) -So when oclose expands superclasses we'll get a (a ~# [b]) superclass.+So when closeWrtFunDeps expands superclasses we'll get a (a ~# [b]) superclass. But that's an EqPred not a ClassPred, and we jolly well do want to account for the mutual functional dependencies implied by (t1 ~# t2).-Hence the EqPred handling in oclose. See #10778.+Hence the EqPred handling in closeWrtFunDeps. See #10778. Note [Care with type functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -533,7 +539,7 @@ type family G c d = r | r -> d Now consider- oclose (C (F a b) (G c d)) {a,b}+ closeWrtFunDeps (C (F a b) (G c d)) {a,b} Knowing {a,b} fixes (F a b) regardless of the injectivity of F. But knowing (G c d) fixes only {d}, because G is only injective@@ -542,12 +548,14 @@ Hence the tyCoVarsOfTypes/injTyVarsOfTypes dance in tv_fds. -} -oclose :: [PredType] -> TyCoVarSet -> TyCoVarSet+closeWrtFunDeps :: [PredType] -> TyCoVarSet -> TyCoVarSet -- See Note [The liberal coverage condition]-oclose preds fixed_tvs+closeWrtFunDeps preds fixed_tvs | null tv_fds = fixed_tvs -- Fast escape hatch for common case.- | otherwise = fixVarSet extend fixed_tvs+ | otherwise = assert (closeOverKinds fixed_tvs == fixed_tvs)+ $ fixVarSet extend fixed_tvs where+ extend fixed_tvs = foldl' add fixed_tvs tv_fds where add fixed_tvs (ls,rs)@@ -673,8 +681,9 @@ -- Hence, we Nothing-ise the tb and tc types right here -- -- Result list is same length as input list, just with more Nothings-trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs- = zipWith select clas_tvs mb_tcs+trimRoughMatchTcs _clas_tvs _ [] = panic "trimRoughMatchTcs: nullary [RoughMatchTc]"+trimRoughMatchTcs clas_tvs (ltvs, _) (cls:mb_tcs)+ = cls : zipWith select clas_tvs mb_tcs where select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc- | otherwise = OtherTc+ | otherwise = RM_WildCard
compiler/GHC/Tc/Module.hs view
@@ -91,7 +91,6 @@ import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) import GHC.Rename.HsType import GHC.Rename.Expr-import GHC.Rename.Utils ( HsDocContext(..) ) import GHC.Rename.Fixity ( lookupFixityRn ) import GHC.Rename.Names import GHC.Rename.Env@@ -401,7 +400,7 @@ tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env, tcg_imports = tcg_imports gbl `plusImportAvails` imports, tcg_rn_imports = rn_imports,- tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,+ tcg_inst_env = tcg_inst_env gbl `unionInstEnv` home_insts, tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) home_fam_insts, tcg_hpc = hpc_info@@ -1560,10 +1559,13 @@ tcSemigroupWarnings :: TcM () tcSemigroupWarnings = do- traceTc "tcSemigroupWarnings" empty- let warnFlag = Opt_WarnSemigroup- tcPreludeClashWarn warnFlag sappendName- tcMissingParentClassWarn warnFlag monoidClassName semigroupClassName+ mod <- getModule+ -- ghc-prim doesn't depend on base+ unless (moduleUnit mod == primUnit) $ do+ traceTc "tcSemigroupWarnings" empty+ let warnFlag = Opt_WarnSemigroup+ tcPreludeClashWarn warnFlag sappendName+ tcMissingParentClassWarn warnFlag monoidClassName semigroupClassName -- | Warn on local definitions of names that would clash with future Prelude@@ -1721,7 +1723,7 @@ -- "<location>: Warning: <type> is an instance of <is> but not -- <should>" e.g. "Foo is an instance of Monad but not Applicative" ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst- warnMsg (KnownTc name:_) =+ warnMsg (RM_KnownTc name:_) = addDiagnosticAt instLoc $ TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ hsep [ (quotes . ppr . nameOccName) name@@ -1734,7 +1736,7 @@ hsep [ text "This will become an error in" , text "a future release." ] warnMsg _ = pure ()- ; when (null shouldInsts && null instanceMatches) $+ ; when (nullUnifiers shouldInsts && null instanceMatches) $ warnMsg (is_tcs isInst) } @@ -1806,9 +1808,14 @@ ctxt = FunSigCtxt main_name NoRRC ; main_id <- tcLookupId main_name ; (io_ty,_) <- getIOType+ ; let main_ty = idType main_id+ eq_orig = TypeEqOrigin { uo_actual = main_ty+ , uo_expected = io_ty+ , uo_thing = Nothing+ , uo_visible = True } ; (_, lie) <- captureTopConstraints $ setMainCtxt main_name io_ty $- tcSubTypeSigma ctxt (idType main_id) io_ty+ tcSubTypeSigma eq_orig ctxt main_ty io_ty ; return lie } } } } checkMain :: Bool -- False => no 'module M(..) where' header at all@@ -1898,7 +1905,7 @@ ; (ev_binds, main_expr) <- setMainCtxt main_name io_ty $ tcCheckMonoExpr main_expr_rn io_ty - -- See Note [Root-main Id]+ -- See Note [Root-main id] -- Construct the binding -- :Main.main :: IO res_ty = runMainIO res_ty main ; run_main_id <- tcLookupId runMainIOName@@ -2041,7 +2048,7 @@ withDefaultingPlugins hsc_env $ withHoleFitPlugins hsc_env $ do { traceTc "setInteractiveContext" $ vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))- , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts)+ , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) (instEnvElts ic_insts)) , text "icReaderEnv (LocalDef)" <+> vcat (map ppr [ local_gres | gres <- nonDetOccEnvElts (icReaderEnv icxt) , let local_gres = filter isLocalGRE gres@@ -2064,13 +2071,12 @@ where gbl_env' = gbl_env { tcg_rdr_env = icReaderEnv icxt , tcg_type_env = type_env- , tcg_inst_env = extendInstEnvList- (extendInstEnvList (tcg_inst_env gbl_env) ic_insts)- home_insts++ , tcg_inst_env = tcg_inst_env gbl_env `unionInstEnv` ic_insts `unionInstEnv` home_insts , tcg_fam_inst_env = extendFamInstEnvList- (extendFamInstEnvList (tcg_fam_inst_env gbl_env)- ic_finsts)- home_fam_insts+ (extendFamInstEnvList (tcg_fam_inst_env gbl_env)+ ic_finsts)+ home_fam_insts , tcg_field_env = mkNameEnv con_fields -- setting tcg_field_env is necessary -- to make RecordWildCards work (test: ghci049)@@ -2103,7 +2109,7 @@ = Right thing type_env1 = mkTypeEnvWithImplicits top_ty_things- type_env = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts)+ type_env = extendTypeEnvWithIds type_env1 (map instanceDFunId (instEnvElts ic_insts)) -- Putting the dfuns in the type_env -- is just to keep Core Lint happy @@ -2569,14 +2575,12 @@ mkPhiTy (map idType dicts) res_ty } ; ty <- zonkTcType all_expr_ty ; - -- We normalise type families, so that the type of an expression is the- -- same as of a bound expression (GHC.Tc.Gen.Bind.mkInferredPolyId). See Trac- -- #10321 for further discussion.+ -- See Note [Normalising the type in :type] fam_envs <- tcGetFamInstEnvs ;- -- normaliseType returns a coercion which we discard, so the Role is- -- irrelevant- return (reductionReducedType (normaliseType fam_envs Nominal ty))- }+ let { normalised_type = reductionReducedType $ normaliseType fam_envs Nominal ty+ -- normaliseType returns a coercion which we discard, so the Role is irrelevant.+ ; final_type = if isSigmaTy res_ty then ty else normalised_type } ;+ return final_type } where -- Optionally instantiate the type of the expression -- See Note [TcRnExprMode]@@ -2601,6 +2605,31 @@ Solution: use tcInferSigma, which in turn uses tcInferApp, which has a special case for application chains.++Note [Normalising the type in :type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In :t <expr> we usually normalise the type (to simplify type functions)+before displaying the result. Reason (see #10321): otherwise we may show+types like+ <expr> :: Vec (1+2) Int+rather than the simpler+ <expr> :: Vec 3 Int+In GHC.Tc.Gen.Bind.mkInferredPolyId we normalise for a very similar reason.++However this normalisation is less helpful when <expr> is just+an identifier, whose user-written type happens to contain type-function+applications. E.g. (#20974)+ test :: F [Monad, A, B] m => m ()+where F is a type family. If we say `:t test`, we'd prefer to see+the type family un-expanded.++We adopt the following ad-hoc solution: if the type inferred for <expr>+(before generalisation, namely res_ty) is a SigmaType (i.e. is not+fully instantiated) then do not normalise; otherwise normalise.+This is not ideal; for example, suppose x :: F Int. Then+ :t x+would be normalised because `F Int` is not a SigmaType. But+anything here is ad-hoc, and it's a user-sought improvement. -} --------------------------@@ -2973,6 +3002,7 @@ | otherwise = hasTopUserName id && case idDetails id of VanillaId -> True+ StrictWorkerId{} -> True RecSelId {} -> True ClassOpId {} -> True FCallId {} -> True
compiler/GHC/Tc/Plugin.hs view
@@ -41,7 +41,6 @@ -- * Creating constraints newWanted,- newDerived, newGiven, newCoercionHole, @@ -166,10 +165,6 @@ newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence newWanted loc pty = unsafeTcPluginTcM (TcM.newWantedWithLoc loc pty)---- | Create a new derived constraint.-newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence-newDerived loc pty = return CtDerived { ctev_pred = pty, ctev_loc = loc } -- | Create a new given constraint, with the supplied evidence. --
compiler/GHC/Tc/Solver.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE MultiWayIf #-} module GHC.Tc.Solver( InferMode(..), simplifyInfer, findInferredDiff,@@ -22,18 +23,15 @@ promoteTyVarSet, simplifyAndEmitFlatConstraints, -- For Rules we need these- solveWanteds, solveWantedsAndDrop,- approximateWC, runTcSDeriveds,-- -- We need this for valid hole-fits- runTcSDerivedsEarlyAbort+ solveWanteds,+ approximateWC ) where import GHC.Prelude import GHC.Data.Bag-import GHC.Core.Class ( Class, classKey, classTyCon )+import GHC.Core.Class import GHC.Driver.Session import GHC.Tc.Utils.Instantiate import GHC.Data.List.SetOps@@ -54,12 +52,13 @@ import GHC.Tc.Solver.InertSet import GHC.Tc.Solver.Monad as TcS import GHC.Tc.Types.Constraint+import GHC.Tc.Instance.FunDeps import GHC.Core.Predicate import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.Ppr-import GHC.Core.TyCon ( TyConBinder )+import GHC.Core.TyCon ( TyConBinder, isTypeFamilyTyCon ) import GHC.Builtin.Types ( liftedRepTy, manyDataConTy, liftedDataConTy ) import GHC.Core.Unify ( tcMatchTyKi ) import GHC.Utils.Misc@@ -75,6 +74,7 @@ import Data.Foldable ( toList ) import Data.List ( partition ) import Data.List.NonEmpty ( NonEmpty(..) )+import GHC.Data.Maybe ( mapMaybe ) {- *********************************************************************************@@ -484,7 +484,7 @@ simplifyTopWanteds :: WantedConstraints -> TcS WantedConstraints -- See Note [Top-level Defaulting Plan] simplifyTopWanteds wanteds- = do { wc_first_go <- nestTcS (solveWantedsAndDrop wanteds)+ = do { wc_first_go <- nestTcS (solveWanteds wanteds) -- This is where the main work happens ; dflags <- getDynFlags ; try_tyvar_defaulting dflags wc_first_go }@@ -519,7 +519,7 @@ = do { something_happened <- applyDefaultingRules wc -- See Note [Top-level Defaulting Plan] ; if something_happened- then do { wc_residual <- nestTcS (solveWantedsAndDrop wc)+ then do { wc_residual <- nestTcS (solveWanteds wc) ; try_class_defaulting wc_residual } -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence else try_callstack_defaulting wc }@@ -677,7 +677,7 @@ Secondly, when should these heuristics be enforced? We enforced them when the type-class method call site is in a module marked `-XSafe` or `-XTrustworthy`. This allows `-XUnsafe` modules to operate without restriction, and for Safe-Haskell inferrence to infer modules with unsafe overlaps as unsafe.+Haskell inference to infer modules with unsafe overlaps as unsafe. One alternative design would be to also consider if an instance was imported as a `safe` import or not and only apply the restriction to instances imported@@ -745,13 +745,13 @@ IORefs called `tcg_safe_infer` and `tcg_safe_infer_reason`. 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safe_infer` after type-checking, calling- `GHC.Driver.Main.markUnsafeInfer` (passing the reason along) when safe-inferrence+ `GHC.Driver.Main.markUnsafeInfer` (passing the reason along) when safe-inference failed. Note [No defaulting in the ambiguity check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When simplifying constraints for the ambiguity check, we use-solveWantedsAndDrop, not simplifyTopWanteds, so that we do no defaulting.+solveWanteds, not simplifyTopWanteds, so that we do no defaulting. #11947 was an example: f :: Num a => Int -> Int This is ambiguous of course, but we don't want to default the@@ -807,7 +807,7 @@ simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM () simplifyAmbiguityCheck ty wanteds = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds)- ; (final_wc, _) <- runTcS $ solveWantedsAndDrop wanteds+ ; (final_wc, _) <- runTcS $ solveWanteds wanteds -- NB: no defaulting! See Note [No defaulting in the ambiguity check] ; traceTc "End simplifyAmbiguityCheck }" empty@@ -835,7 +835,7 @@ simplifyDefault theta = do { traceTc "simplifyDefault" empty ; wanteds <- newWanteds DefaultOrigin theta- ; unsolved <- runTcSDeriveds (solveWantedsAndDrop (mkSimpleWC wanteds))+ ; (unsolved, _) <- runTcS (solveWanteds (mkSimpleWC wanteds)) ; return (isEmptyWC unsolved) } ------------------@@ -941,7 +941,7 @@ (sat, _new_inerts) <- runTcSInerts inerts $ do traceTcS "checkWanteds {" (ppr inerts <+> ppr wanteds) -- See Note [Superclasses and satisfiability]- wcs <- solveWantedsAndDrop (mkSimpleWC cts)+ wcs <- solveWanteds (mkSimpleWC cts) traceTcS "checkWanteds }" (ppr wcs) return (isSolvedWC wcs) return sat@@ -1023,6 +1023,55 @@ has a strictly-increased level compared to the ambient level outside the let binding. +Note [Inferring principal types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't always infer principal types. For instance, the inferred type for++> f x = show [x]++is++> f :: Show a => a -> String++This is not the most general type if we allow flexible contexts.+Indeed, if we try to write the following++> g :: Show [a] => a -> String+> g x = f x++we get the error:++ * Could not deduce (Show a) arising from a use of `f'+ from the context: Show [a]++Though replacing f x in the right-hand side of g with the definition+of f x works, the call to f x does not. This is the hallmark of+unprincip{led,al} types.++Another example:++> class C a+> class D a where+> d :: a+> instance C a => D a where+> d = undefined+> h _ = d -- argument is to avoid the monomorphism restriction++The inferred type for h is++> h :: C a => t -> a++even though++> h :: D a => t -> a++is more general.++The fix is easy: don't simplify constraints before inferring a type.+That is, have the inferred type quantify over all constraints that arise+in a definition's right-hand side, even if they are simplifiable.+Unfortunately, this would yield all manner of unwieldy types,+and so we won't do so. -} -- | How should we choose which constraints to quantify over?@@ -1032,7 +1081,7 @@ -- the :type +d case; this mode refuses -- to quantify over any defaultable constraint | NoRestrictions -- ^ Quantify over any constraint that- -- satisfies 'GHC.Tc.Utils.TcType.pickQuantifiablePreds'+ -- satisfies pickQuantifiablePreds instance Outputable InferMode where ppr ApplyMR = text "ApplyMR"@@ -1087,11 +1136,12 @@ ; ev_binds_var <- TcM.newTcEvBinds ; psig_evs <- newWanteds AnnOrigin psig_theta- ; wanted_transformed_incl_derivs+ ; wanted_transformed <- setTcLevel rhs_tclvl $ runTcSWithEvBinds ev_binds_var $ solveWanteds (mkSimpleWC psig_evs `andWC` wanteds) -- psig_evs : see Note [Add signature contexts as wanteds]+ -- See Note [Inferring principal types] -- Find quant_pred_candidates, the predicates that -- we'll consider quantifying over@@ -1099,12 +1149,9 @@ -- the psig_theta; it's just the extra bit -- NB2: We do not do any defaulting when inferring a type, this can lead -- to less polymorphic types, see Note [Default while Inferring]- ; wanted_transformed_incl_derivs <- TcM.zonkWC wanted_transformed_incl_derivs- ; let definite_error = insolubleWC wanted_transformed_incl_derivs+ ; wanted_transformed <- TcM.zonkWC wanted_transformed+ ; let definite_error = insolubleWC wanted_transformed -- See Note [Quantification with errors]- -- NB: must include derived errors in this test,- -- hence "incl_derivs"- wanted_transformed = dropDerivedWC wanted_transformed_incl_derivs quant_pred_candidates | definite_error = [] | otherwise = ctsPreds (approximateWC False wanted_transformed)@@ -1208,9 +1255,9 @@ ; let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) lcl_env given_cts = mkGivens given_loc given_ids - ; residual <- runTcSDeriveds $- do { _ <- solveSimpleGivens given_cts- ; solveSimpleWanteds (listToBag (map mkNonCanonical wanteds)) }+ ; (residual, _) <- runTcS $+ do { _ <- solveSimpleGivens given_cts+ ; solveSimpleWanteds (listToBag (map mkNonCanonical wanteds)) } -- NB: There are no meta tyvars fromn this level annotated_theta -- because we have either promoted them or unified them -- See `Note [Quantification and partial signatures]` Wrinkle 2@@ -1306,19 +1353,21 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If the monomorphism restriction does not apply, then we quantify as follows: -* Step 1. Take the global tyvars, and "grow" them using the equality- constraints+* Step 1: decideMonoTyVars.+ Take the global tyvars, and "grow" them using functional dependencies E.g. if x:alpha is in the environment, and alpha ~ [beta] (which can happen because alpha is untouchable here) then do not quantify over beta, because alpha fixes beta, and beta is effectively free in- the environment too+ the environment too; this logic extends to general fundeps, not+ just equalities We also account for the monomorphism restriction; if it applies, add the free vars of all the constraints. Result is mono_tvs; we will not quantify over these. -* Step 2. Default any non-mono tyvars (i.e ones that are definitely+* Step 2: defaultTyVarsAndSimplify.+ Default any non-mono tyvars (i.e ones that are definitely not going to become further constrained), and re-simplify the candidate constraints. @@ -1330,21 +1379,177 @@ This is all very tiresome. -* Step 3: decide which variables to quantify over, as follows:+ This step also promotes the mono_tvs from Step 1. See+ Note [Promote monomorphic tyvars]. In fact, the *only*+ use of the mono_tvs from Step 1 is to promote them here.+ This promotion effectively stops us from quantifying over them+ later, in Step 3. Because the actual variables to quantify+ over are determined in Step 3 (not in Step 1), it is OK for+ the mono_tvs to be missing some variables free in the+ environment. This is why removing the psig_qtvs is OK in+ decideMonoTyVars. Test case for this scenario: T14479. - - Take the free vars of the tau-type (zonked_tau_tvs) and "grow"- them using all the constraints. These are tau_tvs_plus+* Step 3: decideQuantifiedTyVars.+ Decide which variables to quantify over, as follows: - - Use quantifyTyVars to quantify over (tau_tvs_plus - mono_tvs), being- careful to close over kinds, and to skolemise the quantified tyvars.- (This actually unifies each quantifies meta-tyvar with a fresh skolem.)+ - Take the free vars of the partial-type-signature types and constraints,+ and the tau-type (zonked_tau_tvs), and then "grow"+ them using all the constraints. These are grown_tcvs.+ See Note [growThetaTyVars vs closeWrtFunDeps]. + - Use quantifyTyVars to quantify over the free variables of all the types+ involved, but only those in the grown_tcvs.+ Result is qtvs. * Step 4: Filter the constraints using pickQuantifiablePreds and the qtvs. We have to zonk the constraints first, so they "see" the freshly created skolems. +Note [Lift equality constraints when quantifying]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We can't quantify over a constraint (t1 ~# t2) because that isn't a+predicate type; see Note [Types for coercions, predicates, and evidence]+in GHC.Core.TyCo.Rep.++So we have to 'lift' it to (t1 ~ t2). Similarly (~R#) must be lifted+to Coercible.++This tiresome lifting is the reason that pick_me (in+pickQuantifiablePreds) returns a Maybe rather than a Bool.++Note [Inheriting implicit parameters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:++ f x = (x::Int) + ?y++where f is *not* a top-level binding.+From the RHS of f we'll get the constraint (?y::Int).+There are two types we might infer for f:++ f :: Int -> Int++(so we get ?y from the context of f's definition), or++ f :: (?y::Int) => Int -> Int++At first you might think the first was better, because then+?y behaves like a free variable of the definition, rather than+having to be passed at each call site. But of course, the WHOLE+IDEA is that ?y should be passed at each call site (that's what+dynamic binding means) so we'd better infer the second.++BOTTOM LINE: when *inferring types* you must quantify over implicit+parameters, *even if* they don't mention the bound type variables.+Reason: because implicit parameters, uniquely, have local instance+declarations. See pickQuantifiablePreds.++Note [Quantifying over equality constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Should we quantify over an equality constraint (s ~ t)? In general, we don't.+Doing so may simply postpone a type error from the function definition site to+its call site. (At worst, imagine (Int ~ Bool)).++However, consider this+ forall a. (F [a] ~ Int) => blah+Should we quantify over the (F [a] ~ Int). Perhaps yes, because at the call+site we will know 'a', and perhaps we have instance F [Bool] = Int.+So we *do* quantify over a type-family equality where the arguments mention+the quantified variables.++Note [Unconditionally resimplify constraints when quantifying]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+During quantification (in defaultTyVarsAndSimplify, specifically), we re-invoke+the solver to simplify the constraints before quantifying them. We do this for+two reasons, enumerated below. We could, in theory, detect when either of these+cases apply and simplify only then, but collecting this information is bothersome,+and simplifying redundantly causes no real harm. Note that this code path+happens only for definitions+ * without a type signature+ * when -XMonoLocalBinds does not apply+ * with unsolved constraints+and so the performance cost will be small.++1. Defaulting++Defaulting the variables handled by defaultTyVar may unlock instance simplifications.+Example (typecheck/should_compile/T20584b):++ with (t :: Double) (u :: String) = printf "..." t u++We know the types of t and u, but we do not know the return type of `with`. So, we+assume `with :: alpha`, where `alpha :: TYPE rho`. The type of printf is+ printf :: PrintfType r => String -> r+The occurrence of printf is instantiated with a fresh var beta. We then get+ beta := Double -> String -> alpha+and+ [W] PrintfType (Double -> String -> alpha)++Module Text.Printf exports+ instance (PrintfArg a, PrintfType r) => PrintfType (a -> r)+and it looks like that instance should apply.++But I have elided some key details: (->) is polymorphic over multiplicity and+runtime representation. Here it is in full glory:+ [W] PrintfType ((Double :: Type) %m1 -> (String :: Type) %m2 -> (alpha :: TYPE rho))+ instance (PrintfArg a, PrintfType r) => PrintfType ((a :: Type) %Many -> (r :: Type))++Because we do not know that m1 is Many, we cannot use the instance. (Perhaps a better instance+would have an explicit equality constraint to the left of =>, but that's not what we have.)+Then, in defaultTyVarsAndSimplify, we get m1 := Many, m2 := Many, and rho := LiftedRep.+Yet it's too late to simplify the quantified constraint, and thus GHC infers+ wait :: PrintfType (Double -> String -> t) => Double -> String -> t+which is silly. Simplifying again after defaulting solves this problem.++2. Interacting functional dependencies++Suppose we have++ class C a b | a -> b++and we are running simplifyInfer over++ forall[2] x. () => [W] C a beta1[1]+ forall[2] y. () => [W] C a beta2[1]++These are two implication constraints, both of which contain a+wanted for the class C. Neither constraint mentions the bound+skolem. We might imagine that these constraint could thus float+out of their implications and then interact, causing beta1 to unify+with beta2, but constraints do not currently float out of implications.++Unifying the beta1 and beta2 is important. Without doing so, then we might+infer a type like (C a b1, C a b2) => a -> a, which will fail to pass the+ambiguity check, which will say (rightly) that it cannot unify b1 with b2, as+required by the fundep interactions. This happens in the parsec library, and+in test case typecheck/should_compile/FloatFDs.++If we re-simplify, however, the two fundep constraints will interact, causing+a unification between beta1 and beta2, and all will be well. The key step+is that this simplification happens *after* the call to approximateWC in+simplifyInfer.++Note [Do not quantify over constraints that determine a variable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (typecheck/should_compile/tc231), where we're trying to infer+the type of a top-level declaration. We have+ class Zork s a b | a -> b+and the candidate constraint at the end of simplifyInfer is+ [W] Zork alpha (Z [Char]) beta+We definitely do want to quantify over alpha (which is mentioned in+the tau-type). But we do *not* want to quantify over beta: it is+determined by the functional dependency on Zork: note that the second+argument to Zork in the Wanted is a variable-free Z [Char].++The question here: do we want to quantify over the constraint? Definitely not.+Since we're not quantifying over beta, GHC has no choice but to zap beta+to Any, and then we infer a type involving (Zork a (Z [Char]) Any => ...). No no no.++The no_fixed_dependencies check in pickQuantifiablePreds eliminates this+candidate from the pool. Because there are no Zork instances in scope, this+program is rejected.+ -} decideQuantification@@ -1445,7 +1650,7 @@ -- Decide which tyvars and covars cannot be generalised: -- (a) Free in the environment -- (b) Mentioned in a constraint we can't generalise--- (c) Connected by an equality to (a) or (b)+-- (c) Connected by an equality or fundep to (a) or (b) -- Also return CoVars that appear free in the final quantified types -- we can't quantify over these, and we must make sure they are in scope decideMonoTyVars infer_mode name_taus psigs candidates@@ -1475,7 +1680,7 @@ mono_tvs0 = filterVarSet (not . isQuantifiableTv tc_lvl) $ tyCoVarsOfTypes candidates -- We need to grab all the non-quantifiable tyvars in the- -- candidates so that we can grow this set to find other+ -- types so that we can grow this set to find other -- non-quantifiable tyvars. This can happen with something -- like -- f x y = ...@@ -1487,30 +1692,47 @@ -- alpha. Actual test case: typecheck/should_compile/tc213 mono_tvs1 = mono_tvs0 `unionVarSet` co_var_tvs+ -- mono_tvs1 is now the set of variables from an outer scope+ -- (that's mono_tvs0) and the set of covars, closed over kinds.+ -- Given this set of variables we know we will not quantify,+ -- we want to find any other variables that are determined by this+ -- set, by functional dependencies or equalities. We thus use+ -- closeWrtFunDeps to find all further variables determined by this root+ -- set. See Note [growThetaTyVars vs closeWrtFunDeps] - eq_constraints = filter isEqPrimPred candidates- mono_tvs2 = growThetaTyVars eq_constraints mono_tvs1+ non_ip_candidates = filterOut isIPLikePred candidates+ -- implicit params don't really determine a type variable+ -- (that is, we might have IP "c" Bool and IP "c" Int in different+ -- places within the same program), and+ -- skipping this causes implicit params to monomorphise too many+ -- variables; see Note [Inheriting implicit parameters] in+ -- GHC.Tc.Solver. Skipping causes typecheck/should_compile/tc219+ -- to fail. + mono_tvs2 = closeWrtFunDeps non_ip_candidates mono_tvs1+ -- mono_tvs2 now contains any variable determined by the "root+ -- set" of monomorphic tyvars in mono_tvs1.+ constrained_tvs = filterVarSet (isQuantifiableTv tc_lvl) $- (growThetaTyVars eq_constraints- (tyCoVarsOfTypes no_quant)- `minusVarSet` mono_tvs2)- `delVarSetList` psig_qtvs+ closeWrtFunDeps non_ip_candidates (tyCoVarsOfTypes no_quant)+ `minusVarSet` mono_tvs2 -- constrained_tvs: the tyvars that we are not going to -- quantify solely because of the monomorphism restriction --- -- (`minusVarSet` mono_tvs2`): a type variable is only+ -- (`minusVarSet` mono_tvs2): a type variable is only -- "constrained" (so that the MR bites) if it is not- -- free in the environment (#13785)- --+ -- free in the environment (#13785) or is determined+ -- by some variable that is free in the env't++ mono_tvs = (mono_tvs2 `unionVarSet` constrained_tvs)+ `delVarSetList` psig_qtvs -- (`delVarSetList` psig_qtvs): if the user has explicitly -- asked for quantification, then that request "wins"- -- over the MR. Note: do /not/ delete psig_qtvs from- -- mono_tvs1, because mono_tvs1 cannot under any circumstances- -- be quantified (#14479); see- -- Note [Quantification and partial signatures], Wrinkle 3, 4-- mono_tvs = mono_tvs2 `unionVarSet` constrained_tvs+ -- over the MR.+ --+ -- What if a psig variable is also free in the environment+ -- (i.e. says "no" to isQuantifiableTv)? That's OK: explanation+ -- in Step 2 of Note [Deciding quantification]. -- Warn about the monomorphism restriction ; when (case infer_mode of { ApplyMR -> True; _ -> False}) $ do@@ -1522,7 +1744,6 @@ , text "mono_tvs0 =" <+> ppr mono_tvs0 , text "no_quant =" <+> ppr no_quant , text "maybe_quant =" <+> ppr maybe_quant- , text "eq_constraints =" <+> ppr eq_constraints , text "mono_tvs =" <+> ppr mono_tvs , text "co_vars =" <+> ppr co_vars ] @@ -1546,16 +1767,17 @@ ------------------- defaultTyVarsAndSimplify :: TcLevel- -> TyCoVarSet+ -> TyCoVarSet -- Promote these mono-tyvars -> [PredType] -- Assumed zonked -> TcM [PredType] -- Guaranteed zonked--- Default any tyvar free in the constraints,+-- Promote the known-monomorphic tyvars;+-- Default any tyvar free in the constraints; -- and re-simplify in case the defaulting allows further simplification defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates = do { -- Promote any tyvars that we cannot generalise -- See Note [Promote monomorphic tyvars] ; traceTc "decideMonoTyVars: promotion:" (ppr mono_tvs)- ; any_promoted <- promoteTyVarSet mono_tvs+ ; _ <- promoteTyVarSet mono_tvs -- Default any kind/levity vars ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs}@@ -1565,35 +1787,34 @@ -- the constraints generated ; poly_kinds <- xoptM LangExt.PolyKinds- ; default_kvs <- mapM (default_one poly_kinds True)- (dVarSetElems cand_kvs)- ; default_tvs <- mapM (default_one poly_kinds False)- (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs))- ; let some_default = or default_kvs || or default_tvs+ ; mapM_ (default_one poly_kinds True) (dVarSetElems cand_kvs)+ ; mapM_ (default_one poly_kinds False) (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs)) - ; case () of- _ | some_default -> simplify_cand candidates- | any_promoted -> mapM TcM.zonkTcType candidates- | otherwise -> return candidates+ ; simplify_cand candidates } where default_one poly_kinds is_kind_var tv | not (isMetaTyVar tv)- = return False+ = return () | tv `elemVarSet` mono_tvs- = return False+ = return () | otherwise- = defaultTyVar+ = void $ defaultTyVar (if not poly_kinds && is_kind_var then DefaultKindVars else NonStandardDefaulting DefaultNonStandardTyVars) -- NB: only pass 'DefaultKindVars' when we know we're dealing with a kind variable. tv + -- this common case (no inferred contraints) should be fast+ simplify_cand [] = return []+ -- see Note [Unconditionally resimplify constraints when quantifying] simplify_cand candidates- = do { clone_wanteds <- newWanteds DefaultOrigin candidates- ; WC { wc_simple = simples } <- setTcLevel rhs_tclvl $- simplifyWantedsTcM clone_wanteds+ = do { WC { wc_simple = simples } <- setTcLevel rhs_tclvl $+ do { wanteds <- newWanteds DefaultOrigin candidates+ -- build wanteds at bumped level because newConcreteHole+ -- whips up fresh metavariables+ ; simplifyWantedsTcM wanteds } -- Discard evidence; simples is fully zonked ; let new_candidates = ctsPreds simples@@ -1625,6 +1846,7 @@ seed_tys = psig_tys ++ tau_tys -- Now "grow" those seeds to find ones reachable via 'candidates'+ -- See Note [growThetaTyVars vs closeWrtFunDeps] grown_tcvs = growThetaTyVars candidates (tyCoVarsOfTypes seed_tys) -- Now we have to classify them into kind variables and type variables@@ -1652,15 +1874,90 @@ ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs_plus } ------------------+-- | When inferring types, should we quantify over a given predicate?+-- Generally true of classes; generally false of equality constraints.+-- Equality constraints that mention quantified type variables and+-- implicit variables complicate the story. See Notes+-- [Inheriting implicit parameters] and [Quantifying over equality constraints]+pickQuantifiablePreds+ :: TyVarSet -- Quantifying over these+ -> TcThetaType -- Proposed constraints to quantify+ -> TcThetaType -- A subset that we can actually quantify+-- This function decides whether a particular constraint should be+-- quantified over, given the type variables that are being quantified+pickQuantifiablePreds qtvs theta+ = let flex_ctxt = True in -- Quantify over non-tyvar constraints, even without+ -- -XFlexibleContexts: see #10608, #10351+ -- flex_ctxt <- xoptM Opt_FlexibleContexts+ mapMaybe (pick_me flex_ctxt) theta+ where+ pick_me flex_ctxt pred+ = case classifyPredType pred of++ ClassPred cls tys+ | Just {} <- isCallStackPred cls tys+ -- NEVER infer a CallStack constraint. Otherwise we let+ -- the constraints bubble up to be solved from the outer+ -- context, or be defaulted when we reach the top-level.+ -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence+ -> Nothing++ | isIPClass cls+ -> Just pred -- See Note [Inheriting implicit parameters]++ | pick_cls_pred flex_ctxt cls tys+ -> Just pred++ EqPred eq_rel ty1 ty2+ | quantify_equality eq_rel ty1 ty2+ , Just (cls, tys) <- boxEqPred eq_rel ty1 ty2+ -- boxEqPred: See Note [Lift equality constraints when quantifying]+ , pick_cls_pred flex_ctxt cls tys+ -> Just (mkClassPred cls tys)++ IrredPred ty+ | tyCoVarsOfType ty `intersectsVarSet` qtvs+ -> Just pred++ _ -> Nothing+++ pick_cls_pred flex_ctxt cls tys+ = tyCoVarsOfTypes tys `intersectsVarSet` qtvs+ && (checkValidClsArgs flex_ctxt cls tys)+ -- Only quantify over predicates that checkValidType+ -- will pass! See #10351.+ && (no_fixed_dependencies cls tys)++ -- See Note [Do not quantify over constraints that determine a variable]+ no_fixed_dependencies cls tys+ = and [ qtvs `intersectsVarSet` tyCoVarsOfTypes fd_lhs_tys+ | fd <- cls_fds+ , let (fd_lhs_tys, _) = instFD fd cls_tvs tys ]+ where+ (cls_tvs, cls_fds) = classTvsFds cls++ -- See Note [Quantifying over equality constraints]+ quantify_equality NomEq ty1 ty2 = quant_fun ty1 || quant_fun ty2+ quantify_equality ReprEq _ _ = True++ quant_fun ty+ = case tcSplitTyConApp_maybe ty of+ Just (tc, tys) | isTypeFamilyTyCon tc+ -> tyCoVarsOfTypes tys `intersectsVarSet` qtvs+ _ -> False+++------------------ growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet--- See Note [Growing the tau-tvs using constraints]+-- See Note [growThetaTyVars vs closeWrtFunDeps] growThetaTyVars theta tcvs | null theta = tcvs | otherwise = transCloVarSet mk_next seed_tcvs where seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips (ips, non_ips) = partition isIPLikePred theta- -- See Note [Inheriting implicit parameters] in GHC.Tc.Utils.TcType+ -- See Note [Inheriting implicit parameters] mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips@@ -1695,7 +1992,7 @@ * not forced to be monomorphic (mono_tvs), for example by being free in the environment. -However, in the case of a partial type signature, be doing inference+However, in the case of a partial type signature, we are doing inference *in the presence of a type signature*. For example: f :: _ -> a f x = ...@@ -1709,7 +2006,7 @@ f :: _ -> Maybe a f x = True && x The inferred type of 'f' is f :: Bool -> Bool, but there's a- left-over error of form (HoleCan (Maybe a ~ Bool)). The error-reporting+ left-over error of form (Maybe a ~ Bool). The error-reporting machine expects to find a binding site for the skolem 'a', so we add it to the quantified tyvars. @@ -1750,18 +2047,56 @@ refrain from bogusly quantifying, in GHC.Tc.Solver.decideMonoTyVars. We report the error later, in GHC.Tc.Gen.Bind.chooseInferredQuantifiers. -Note [Growing the tau-tvs using constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-(growThetaTyVars insts tvs) is the result of extending the set- of tyvars, tvs, using all conceivable links from pred+Note [growThetaTyVars vs closeWrtFunDeps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC has two functions, growThetaTyVars and closeWrtFunDeps, both with+the same type and similar behavior. This Note outlines the differences+and why we use one or the other. -E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e}-Then growThetaTyVars preds tvs = {a,b,c}+Both functions take a list of constraints. We will call these the+*candidates*. -Notice that- growThetaTyVars is conservative if v might be fixed by vs- => v `elem` grow(vs,C)+closeWrtFunDeps takes a set of "determined" type variables and finds the+closure of that set with respect to the functional dependencies+within the class constraints in the set of candidates. So, if we+have + class C a b | a -> b+ class D a b -- no fundep+ candidates = {C (Maybe a) (Either b c), D (Maybe a) (Either d e)}++then closeWrtFunDeps {a} will return the set {a,b,c}.+This is because, if `a` is determined, then `b` and `c` are, too,+by functional dependency. closeWrtFunDeps called with any seed set not including+`a` will just return its argument, as only `a` determines any other+type variable (in this example).++growThetaTyVars operates similarly, but it behaves as if every+constraint has a functional dependency among all its arguments.+So, continuing our example, growThetaTyVars {a} will return+{a,b,c,d,e}. Put another way, growThetaTyVars grows the set of+variables to include all variables that are mentioned in the same+constraint (transitively).++We use closeWrtFunDeps in places where we need to know which variables are+*always* determined by some seed set. This includes+ * when determining the mono-tyvars in decideMonoTyVars. If `a`+ is going to be monomorphic, we need b and c to be also: they+ are determined by the choice for `a`.+ * when checking instance coverage, in+ GHC.Tc.Instance.FunDeps.checkInstCoverage++On the other hand, we use growThetaTyVars where we need to know+which variables *might* be determined by some seed set. This includes+ * deciding quantification (GHC.Tc.Gen.Bind.chooseInferredQuantifiers+ and decideQuantifiedTyVars+How can `a` determine (say) `d` in the example above without a fundep?+Suppose we have+ instance (b ~ a, c ~ a) => D (Maybe [a]) (Either b c)+Now, if `a` turns out to be a list, it really does determine b and c.+The danger in overdoing quantification is the creation of an ambiguous+type signature, but this is conveniently caught in the validity checker.+ Note [Quantification with errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we find that the RHS of the definition has some absolutely-insoluble@@ -1790,12 +2125,6 @@ the recovery from failM emits no code at all, so there is no function to run! But -fdefer-type-errors aspires to produce a runnable program. -NB that we must include *derived* errors in the check for insolubles.-Example:- (a::*) ~ Int#-We get an insoluble derived error *~#, and we don't want to discard-it before doing the isInsolubleWC test! (#8262)- Note [Default while Inferring] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Our current plan is that defaulting only happens at simplifyTop and@@ -1877,26 +2206,15 @@ simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints -- Solve the specified Wanted constraints -- Discard the evidence binds--- Discards all Derived stuff in result -- Postcondition: fully zonked simplifyWantedsTcM wanted = do { traceTc "simplifyWantedsTcM {" (ppr wanted)- ; (result, _) <- runTcS (solveWantedsAndDrop (mkSimpleWC wanted))+ ; (result, _) <- runTcS (solveWanteds (mkSimpleWC wanted)) ; result <- TcM.zonkWC result ; traceTc "simplifyWantedsTcM }" (ppr result) ; return result } -solveWantedsAndDrop :: WantedConstraints -> TcS WantedConstraints--- Since solveWanteds returns the residual WantedConstraints,--- it should always be called within a runTcS or something similar,--- Result is not zonked-solveWantedsAndDrop wanted- = do { wc <- solveWanteds wanted- ; return (dropDerivedWC wc) }- solveWanteds :: WantedConstraints -> TcS WantedConstraints--- so that the inert set doesn't mindlessly propagate.--- NB: wc_simples may be wanted /or/ derived now solveWanteds wc@(WC { wc_holes = holes }) = do { cur_lvl <- TcS.getTcLevel ; traceTcS "solveWanteds {" $@@ -1921,7 +2239,7 @@ -> WantedConstraints -> TcS WantedConstraints -- Do a round of solving, and call maybe_simplify_again to iterate -- The 'definitely_redo_implications' flags is False if the only reason we--- are iterating is that we have added some new Derived superclasses (from Wanteds)+-- are iterating is that we have added some new Wanted superclasses -- hoping for fundeps to help us; see Note [Superclass iteration] -- -- Does not affect wc_holes at all; reason: wc_holes never affects anything@@ -1993,15 +2311,15 @@ where class D a b | a -> b class D a b => C a b-We will expand d's superclasses, giving [D] D Int beta, in the hope of geting+We will expand d's superclasses, giving [W] D Int beta, in the hope of geting fundeps to unify beta. Doing so is usually fruitless (no useful fundeps), and if so it seems a pity to waste time iterating the implications (forall b. blah) (If we add new Given superclasses it's a different matter: it's really worth looking at the implications.) Hence the definitely_redo_implications flag to simplify_loop. It's usually-True, but False in the case where the only reason to iterate is new Derived-superclasses. In that case we check whether the new Deriveds actually led to+True, but False in the case where the only reason to iterate is new Wanted+superclasses. In that case we check whether the new Wanteds actually led to any new unifications, and iterate the implications only if so. -} @@ -2055,9 +2373,6 @@ ; solveSimpleGivens givens ; residual_wanted <- solveWanteds wanteds- -- solveWanteds, *not* solveWantedsAndDrop, because- -- we want to retain derived equalities so we can float- -- them out in floatEqualities. ; (has_eqs, given_insols) <- getHasGivenEqs tclvl -- Call getHasGivenEqs /after/ solveWanteds, because@@ -2099,9 +2414,8 @@ ---------------------- setImplicationStatus :: Implication -> TcS (Maybe Implication)--- Finalise the implication returned from solveImplication:--- * Set the ic_status field--- * Trim the ic_wanted field to remove Derived constraints+-- Finalise the implication returned from solveImplication,+-- setting the ic_status field -- Precondition: the ic_status field is not already IC_Solved -- Return Nothing if we can discard the implication altogether setImplicationStatus implic@(Implic { ic_status = status@@ -2170,9 +2484,8 @@ where WC { wc_simple = simples, wc_impl = implics, wc_holes = holes } = wc - pruned_simples = dropDerivedSimples simples pruned_implics = filterBag keep_me implics- pruned_wc = WC { wc_simple = pruned_simples+ pruned_wc = WC { wc_simple = simples , wc_impl = pruned_implics , wc_holes = holes } -- do not prune holes; these should be reported @@ -2546,7 +2859,9 @@ = return False -- the common case approximateWC :: Bool -> WantedConstraints -> Cts--- Postcondition: Wanted or Derived Cts+-- Second return value is the depleted wc+-- Third return value is YesFDsCombined <=> multiple constraints for the same fundep floated+-- Postcondition: Wanted Cts -- See Note [ApproximateWC] -- See Note [floatKindEqualities vs approximateWC] approximateWC float_past_equalities wc@@ -2629,7 +2944,6 @@ contamination stuff. There was zero effect on the testsuite (not even #8155). ------ End of historical note ----------- - Note [DefaultTyVar] ~~~~~~~~~~~~~~~~~~~ defaultTyVar is used on any un-instantiated meta type variables to@@ -2648,7 +2962,7 @@ hand. However we aren't ready to default them fully to () or whatever, because the type-class defaulting rules have yet to run. -An alternate implementation would be to emit a derived constraint setting+An alternate implementation would be to emit a Wanted constraint setting the RuntimeRep variable to LiftedRep, but this seems unnecessarily indirect. Note [Promote _and_ default when inferring]@@ -2769,7 +3083,7 @@ findDefaultableGroups :: ( [Type] , (Bool,Bool) ) -- (Overloaded strings, extended default rules)- -> WantedConstraints -- Unsolved (wanted or derived)+ -> WantedConstraints -- Unsolved -> [(TyVar, [Ct])] findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds | null default_tys@@ -2855,8 +3169,12 @@ ; tc_lvl <- TcS.getTcLevel ; let loc = mkGivenLoc tc_lvl (getSkolemInfo unkSkol) lcl_env -- Equality constraints are possible due to type defaulting plugins- ; wanted_evs <- mapM (newWantedNC loc . substTy subst . ctPred)- wanteds+ ; wanted_evs <- sequence [ newWantedNC loc rewriters pred'+ | wanted <- wanteds+ , CtWanted { ctev_pred = pred+ , ctev_rewriters = rewriters }+ <- return (ctEvidence wanted)+ , let pred' = substTy subst pred ] ; fmap isEmptyWC $ solveSimpleWanteds $ listToBag $ map mkNonCanonical wanted_evs }
compiler/GHC/Tc/Solver/Canonical.hs view
@@ -4,7 +4,7 @@ module GHC.Tc.Solver.Canonical( canonicalize,- unifyDerived,+ unifyWanted, makeSuperClasses, StopOrContinue(..), stopWith, continueWith, andWhenContinue, solveCallStack -- For GHC.Tc.Solver@@ -25,6 +25,7 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Types.EvTerm import GHC.Core.Class+import GHC.Core.DataCon ( dataConName ) import GHC.Core.TyCon import GHC.Core.Multiplicity import GHC.Core.TyCo.Rep -- cleverly decomposes types, good for completeness checking@@ -58,8 +59,10 @@ import Data.List ( zip4 ) import GHC.Types.Basic +import qualified Data.Semigroup as S import Data.Bifunctor ( bimap ) import Data.Foldable ( traverse_ )+import GHC.Tc.Utils.Monad (setTcLevel) {- ************************************************************************@@ -161,7 +164,7 @@ ; emitWork sc_cts ; canClass ev cls tys False fds } - | isWanted ev+ | CtWanted { ctev_rewriters = rewriters } <- ev , Just ip_name <- isCallStackPred cls tys , isPushCallStackOrigin orig -- If we're given a CallStack constraint that arose from a function@@ -175,8 +178,9 @@ -- We change the origin to IPOccOrigin so -- this rule does not fire again. -- See Note [Overview of implicit CallStacks]+ -- in GHC.Tc.Types.Evidence - ; new_ev <- newWantedEvVarNC new_loc pred+ ; new_ev <- newWantedEvVarNC new_loc rewriters pred -- Then we solve the wanted by pushing the call-site -- onto the newly emitted CallStack@@ -219,15 +223,14 @@ canClass ev cls tys pend_sc fds = -- all classes do *nominal* matching assertPpr (ctEvRole ev == Nominal) (ppr ev $$ ppr cls $$ ppr tys) $- do { redns@(Reductions _ xis) <- rewriteArgsNom ev cls_tc tys+ do { (redns@(Reductions _ xis), rewriters) <- rewriteArgsNom ev cls_tc tys ; let redn@(Reduction _ xi) = mkClassPredRedn cls redns mk_ct new_ev = CDictCan { cc_ev = new_ev , cc_tyargs = xis , cc_class = cls , cc_pend_sc = pend_sc , cc_fundeps = fds }- ; mb <- rewriteEvidence ev redn-+ ; mb <- rewriteEvidence rewriters ev redn ; traceTcS "canClass" (vcat [ ppr ev , ppr xi, ppr mb ]) ; return (fmap mk_ct mb) }@@ -244,15 +247,14 @@ We get a Wanted (Eq a), which can only be solved from the superclass of the Given (Ord a). -* For wanteds [W], and deriveds [WD], [D], they may give useful+* For wanteds [W], they may give useful functional dependencies. E.g. class C a b | a -> b where ... class C a b => D a b where ... Now a [W] constraint (D Int beta) has (C Int beta) as a superclass and that might tell us about beta, via C's fundeps. We can get this- by generating a [D] (C Int beta) constraint. It's derived because- we don't actually have to cough up any evidence for it; it's only there- to generate fundep equalities.+ by generating a [W] (C Int beta) constraint. We won't use the evidence,+ but it may lead to unification. See Note [Why adding superclasses can help]. @@ -302,7 +304,7 @@ GHC.Tc.Solver.simpl_loop and solveWanteds. This may succeed in generating (a finite number of) extra Givens,- and extra Deriveds. Both may help the proof.+ and extra Wanteds. Both may help the proof. 3a An important wrinkle: only expand Givens from the current level. Two reasons:@@ -396,7 +398,7 @@ Suppose we want to solve [G] C a b [W] C a beta- Then adding [D] beta~b will let us solve it.+ Then adding [W] beta~b will let us solve it. -- Example 2 (similar but using a type-equality superclass) class (F a ~ b) => C a b@@ -405,8 +407,8 @@ [W] C a beta Follow the superclass rules to add [G] F a ~ b- [D] F a ~ beta- Now we get [D] beta ~ b, and can solve that.+ [W] F a ~ beta+ Now we get [W] beta ~ b, and can solve that. -- Example (tcfail138) class L a b | a -> b@@ -421,9 +423,9 @@ [W] G (Maybe a) Use the instance decl to get [W] C a beta- Generate its derived superclass- [D] L a beta. Now using fundeps, combine with [G] L a b to get- [D] beta ~ b+ Generate its superclass+ [W] L a beta. Now using fundeps, combine with [G] L a b to get+ [W] beta ~ b which is what we want. Note [Danger of adding superclasses during solving]@@ -440,8 +442,8 @@ If we were to be adding the superclasses during simplification we'd get: [W] RealOf e ~ e [W] Normed e- [D] RealOf e ~ fuv- [D] Num fuv+ [W] RealOf e ~ fuv+ [W] Num fuv ==> e := fuv, Num fuv, Normed fuv, RealOf fuv ~ fuv @@ -450,9 +452,6 @@ definitely only once, during canonicalisation, this situation can't happen. -Mind you, now that Wanteds cannot rewrite Derived, I think this particular-situation can't happen.- Note [Nested quantified constraint superclasses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (typecheck/should_compile/T17202)@@ -495,7 +494,7 @@ -} makeSuperClasses :: [Ct] -> TcS [Ct]--- Returns strict superclasses, transitively, see Note [The superclasses story]+-- Returns strict superclasses, transitively, see Note [The superclass story] -- See Note [The superclass story] -- The loop-breaking here follows Note [Expanding superclasses] in GHC.Tc.Utils.TcType -- Specifically, for an incoming (C t) constraint, we return all of (C t)'s@@ -615,18 +614,19 @@ mk_strict_superclasses rec_clss ev tvs theta cls tys | all noFreeVarsOfType tys- = return [] -- Wanteds with no variables yield no deriveds.+ = return [] -- Wanteds with no variables yield no superclass constraints. -- See Note [Improvement from Ground Wanteds] - | otherwise -- Wanted/Derived case, just add Derived superclasses+ | otherwise -- Wanted case, just add Wanted superclasses -- that can lead to improvement. = assertPpr (null tvs && null theta) (ppr tvs $$ ppr theta) $- concatMapM do_one_derived (immSuperClasses cls tys)+ concatMapM do_one (immSuperClasses cls tys) where- loc = ctEvLoc ev+ loc = ctEvLoc ev `updateCtLocOrigin` WantedSuperclassOrigin (ctEvPred ev) - do_one_derived sc_pred- = do { sc_ev <- newDerivedNC loc sc_pred+ do_one sc_pred+ = do { traceTcS "mk_strict_superclasses Wanted" (ppr (mkClassPred cls tys) $$ ppr sc_pred)+ ; sc_ev <- newWantedNC loc (ctEvRewriters ev) sc_pred ; mk_superclasses rec_clss sc_ev [] [] sc_pred } {- Note [Improvement from Ground Wanteds]@@ -634,8 +634,8 @@ Suppose class C b a => D a b and consider [W] D Int Bool-Is there any point in emitting [D] C Bool Int? No! The only point of-emitting superclass constraints for W/D constraints is to get+Is there any point in emitting [W] C Bool Int? No! The only point of+emitting superclass constraints for W constraints is to get improvement, extra unifications that result from functional dependencies. See Note [Why adding superclasses can help] above. @@ -733,8 +733,8 @@ canIrred ev = do { let pred = ctEvPred ev ; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred)- ; redn <- rewrite ev pred- ; rewriteEvidence ev redn `andWhenContinue` \ new_ev ->+ ; (redn, rewriters) <- rewrite ev pred+ ; rewriteEvidence rewriters ev redn `andWhenContinue` \ new_ev -> do { -- Re-classify, in case rewriting has improved its shape -- Code is like the canNC, except@@ -855,8 +855,8 @@ canForAll ev pend_sc = do { -- First rewrite it to apply the current substitution let pred = ctEvPred ev- ; redn <- rewrite ev pred- ; rewriteEvidence ev redn `andWhenContinue` \ new_ev ->+ ; (redn, rewriters) <- rewrite ev pred+ ; rewriteEvidence rewriters ev redn `andWhenContinue` \ new_ev -> do { -- Now decompose into its pieces and solve it -- (It takes a lot less code to rewrite before decomposing.)@@ -868,8 +868,8 @@ solveForAll :: CtEvidence -> [TyVar] -> TcThetaType -> PredType -> Bool -> TcS (StopOrContinue Ct)-solveForAll ev tvs theta pred pend_sc- | CtWanted { ctev_dest = dest } <- ev+solveForAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_loc = loc })+ tvs theta pred _pend_sc = -- See Note [Solving a Wanted forall-constraint] setLclEnv (ctLocEnv loc) $ -- This setLclEnv is important: the emitImplicationTcS uses that@@ -883,7 +883,7 @@ ; (lvl, (w_id, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $- do { wanted_ev <- newWantedEvVarNC loc $+ do { wanted_ev <- newWantedEvVarNC loc rewriters $ substTy subst pred ; return ( ctEvEvId wanted_ev , unitBag (mkNonCanonical wanted_ev)) }@@ -897,15 +897,11 @@ ; stopWith ev "Wanted forall-constraint" } - | isGiven ev -- See Note [Solving a Given forall-constraint]+ -- See Note [Solving a Given forall-constraint]+solveForAll ev@(CtGiven {}) tvs _theta pred pend_sc = do { addInertForAll qci ; stopWith ev "Given forall-constraint" }-- | otherwise- = do { traceTcS "discarding derived forall-constraint" (ppr ev)- ; stopWith ev "Derived forall-constraint" } where- loc = ctEvLoc ev qci = QCI { qci_ev = ev, qci_tvs = tvs , qci_pred = pred, qci_pend_sc = pend_sc } @@ -975,6 +971,44 @@ ==> the second constraint can be decomposed again; 'RuntimeRep' and '[]' are concrete, so we get C: Concrete# Rep, C: Concrete# rr +Note [Solving Concrete constraints requires simplifyArgsWorker]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have+ [W] co :: Concrete# [LiftedRep, IntRep]+and wish to canonicalise it so that we can solve it. Of course, that's really+ [W] co :: Concrete# ((:) @RuntimeRep LiftedRep ((:) @RuntimeRep IntRep ('[] @RuntimeRep)))++We can decompose to+ [W] co1 :: Concrete# RuntimeRep+ [W] co2 :: Concrete# LiftedRep+ [W] co3 :: Concrete# ((:) @RuntimeRep IntRep ('[] @RuntimeRep))++Recall (Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete) that the evidence for+a Concrete# ty constraint is a coercion of type ty ~# alpha, where we require a concrete+type (one that responds True to GHC.Core.Type.isConcrete) to fill in alpha when solving+the constraint. Accordingly, when we create these new Concrete# constraints, we create+new metavariables alpha1 :: Type, alpha2 :: RuntimeRep, alpha3 :: [RuntimeRep], with:++ co1 :: RuntimeRep ~# alpha1+ co2 :: LiftedRep ~# alpha2+ co3 :: '[IntRep] ~# alpha3++and we already have++ co :: [LiftedRep, IntRep] ~# alpha0++We are now solving co. What do we fill in alpha0 with? The naive answer is to say++ alpha0 := (:) alpha1 alpha2 alpha3++but this would be ill-kinded! The first problem is that `(:) alpha1` expects its next+argument to have kind alpha1. (The next argument -- alpha3 -- is problematic, too.) The+second problem is that alpha0 :: [RuntimeRep], but the right-hand side above has kind+[alpha1]. Happily, we have a solution close to hand: simplifyArgsWorker, which deals+with precisely this scenario, of replacing all the arguments to a function (in this case, (:)),+with new arguments but making sure the kinds line up. All we have to do is bundle the information+we have in a form simplifyArgsWorker likes, and then do the reverse from its result.+ -} -- | Canonicalise a 'Concrete#' constraint.@@ -1025,13 +1059,29 @@ canDecomposableConcretePrim ev f_tc args = do { traceTcS "canDecomposableConcretePrim" $ vcat [text "args =" <+> ppr args, text "ev =" <+> ppr ev]- ; arg_cos <- mapM (emit_new_concretePrim_wanted (ctEvLoc ev)) args- ; case ev of- CtWanted { ctev_dest = dest }- -> setWantedEvTerm dest (evCoercion $ mkTyConAppCo Nominal f_tc arg_cos)- _ -> pprPanic "canDecomposableConcretePrim: non-Wanted" $- vcat [ text "ev =" <+> ppr ev- , text "args =" <+> ppr args ]+ ; let ev_lvl+ | CtWanted { ctev_dest = HoleDest hole } <- ev+ , (_, _, _, conc_rhs_ty, Nominal) <- coVarKindsTypesRole (coHoleCoVar hole)+ , Just conc_rhs_tv <- getTyVar_maybe conc_rhs_ty+ , Just lvl <- metaTyVarTcLevel_maybe conc_rhs_tv+ = lvl++ | otherwise+ = pprPanic "canDecomposableConcretePrim" (ppr ev)++ ; (arg_cos, rhs_args)+ <- mapAndUnzipM (emit_new_concretePrim_wanted ev_lvl (ctEvLoc ev)) args++ -- See Note [Solving Concrete constraints requires simplifyArgsWorker]+ ; let (tc_binders, tc_res_kind) = splitPiTys (tyConKind f_tc)+ fvs_args = tyCoVarsOfTypes rhs_args+ ArgsReductions reductions final_co+ = simplifyArgsWorker tc_binders tc_res_kind fvs_args+ (repeat Nominal) (zipWith mkReduction arg_cos rhs_args)+ Reduction concrete_co uncasted_concrete_rhs = mkTyConAppRedn Nominal f_tc reductions+ concrete_rhs = uncasted_concrete_rhs `mkCastTyMCo` mkSymMCo final_co++ ; solveConcretePrimWanted ev concrete_co concrete_rhs ; stopWith ev "Decomposed Concrete#" } -- | Canonicalise a non-decomposable 'Concrete#' constraint.@@ -1049,13 +1099,45 @@ ; continueWith new_ct } -- | Create a new 'Concrete#' Wanted constraint and immediately add it--- to the work list.-emit_new_concretePrim_wanted :: CtLoc -> Type -> TcS Coercion-emit_new_concretePrim_wanted loc ty- = do { (hole, wanted) <- wrapTcS $ newConcretePrimWanted loc ty+-- to the work list. Returns the evidence (a coercion hole) used for the+-- constraint, and the right-hand type (a metavariable) of that coercion+emit_new_concretePrim_wanted :: TcLevel -> CtLoc -> Type -> TcS (Coercion, TcType)+emit_new_concretePrim_wanted ev_lvl loc ty+ = do { (hole, rhs_ty, wanted) <- wrapTcS $ setTcLevel ev_lvl $ newConcretePrimWanted loc ty ; emitWorkNC [wanted]- ; return $ mkHoleCo hole }+ ; return (mkHoleCo hole, rhs_ty) } +-- | Solve a Wanted 'Concrete#' constraint.+--+-- Recall that, when we create a Wanted constraint of the form @Concrete# ty@,+-- we create a metavariable @concrete_tau@ and a coercion hole of type+-- @ty ~# concrete_tau@.+--+-- When we want to solve this constraint, because we have found that+-- @ty@ is indeed equal to a concrete type @rhs@, we thus need to do+-- two things:+--+-- 1. fill the metavariable @concrete_tau := rhs@,+-- 2. fill the coercion hole with the evidence for the equality @ty ~# rhs@.+solveConcretePrimWanted :: HasDebugCallStack+ => CtEvidence -- ^ always a [W] Concrete# ty+ -> Coercion -- ^ @co :: ty ~ rhs@+ -> TcType -- ^ @rhs@, which must be concrete+ -> TcS ()+solveConcretePrimWanted (CtWanted { ctev_dest = dest@(HoleDest hole) }) co rhs+ = do { let Pair _ty concrete_tau = coVarTypes $ coHoleCoVar hole+ tau_tv = getTyVar "solveConcretePrimWanted" concrete_tau+ ; unifyTyVar tau_tv rhs+ ; setWantedEq dest co }++solveConcretePrimWanted ev co rhs+ = pprPanic "solveConcretePrimWanted: no coercion hole to fill" $+ vcat [ text "ev =" <+> ppr ev <> semi <+> text "dest =" <+> case ev of+ CtWanted { ctev_dest = EvVarDest var } -> text "var" <+> ppr var+ _ -> text "XXX NOT EVEN A WANTED XXX"+ , text "co =" <+> ppr co+ , text "rhs =" <+> ppr rhs ]+ {- ********************************************************************** * * * Equalities@@ -1153,7 +1235,7 @@ | ReprEq <- eq_rel , Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2- = can_eq_newtype_nc ev IsSwapped ty2 stuff2 ty1 ps_ty1+ = can_eq_newtype_nc ev IsSwapped ty2 stuff2 ty1 ps_ty1 -- Then, get rid of casts can_eq_nc' rewritten _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2@@ -1219,9 +1301,9 @@ -- No similarity in type structure detected. Rewrite and try again. can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2- = do { redn1@(Reduction _ xi1) <- rewrite ev ps_ty1- ; redn2@(Reduction _ xi2) <- rewrite ev ps_ty2- ; new_ev <- rewriteEqEvidence ev NotSwapped redn1 redn2+ = do { (redn1@(Reduction _ xi1), rewriters1) <- rewrite ev ps_ty1+ ; (redn2@(Reduction _ xi2), rewriters2) <- rewrite ev ps_ty2+ ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 } ----------------------------@@ -1339,7 +1421,7 @@ -- so we must proceed one binder at a time (#13879) can_eq_nc_forall ev eq_rel s1 s2- | CtWanted { ctev_loc = loc, ctev_dest = orig_dest } <- ev+ | CtWanted { ctev_loc = loc, ctev_dest = orig_dest, ctev_rewriters = rewriters } <- ev = do { let free_tvs = tyCoVarsOfTypes [s1,s2] (bndrs1, phi1) = tcSplitForAllTyVarBinders s1 (bndrs2, phi2) = tcSplitForAllTyVarBinders s2@@ -1363,7 +1445,7 @@ -> TcS (TcCoercion, Cts) go (skol_tv:skol_tvs) subst (bndr2:bndrs2) = do { let tv2 = binderVar bndr2- ; (kind_co, wanteds1) <- unify loc Nominal (tyVarKind skol_tv)+ ; (kind_co, wanteds1) <- unify loc rewriters Nominal (tyVarKind skol_tv) (substTy subst (tyVarKind tv2)) ; let subst' = extendTvSubstAndInScope subst tv2 (mkCastTy (mkTyVarTy skol_tv) kind_co)@@ -1375,8 +1457,8 @@ -- Done: unify phi1 ~ phi2 go [] subst bndrs2- = assert (null bndrs2 )- unify loc (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2)+ = assert (null bndrs2) $+ unify loc rewriters (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2) go _ _ _ = panic "cna_eq_nc_forall" -- case (s:ss) [] @@ -1391,18 +1473,18 @@ | otherwise = do { traceTcS "Omitting decomposition of given polytype equality" $- pprEq s1 s2 -- See Note [Do not decompose given polytype equalities]+ pprEq s1 s2 -- See Note [Do not decompose Given polytype equalities] ; stopWith ev "Discard given polytype equality" } where- unify :: CtLoc -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts)+ unify :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts) -- This version returns the wanted constraint rather -- than putting it in the work list- unify loc role ty1 ty2+ unify loc rewriters role ty1 ty2 | ty1 `tcEqType` ty2 = return (mkTcReflCo role ty1, emptyBag) | otherwise- = do { (wanted, co) <- newWantedEq loc role ty1 ty2+ = do { (wanted, co) <- newWantedEq loc rewriters role ty1 ty2 ; return (co, unitBag (mkNonCanonical wanted)) } ---------------------------------@@ -1640,7 +1722,7 @@ ; let redn1 = mkReduction co1 ty1' - ; new_ev <- rewriteEqEvidence ev swapped+ ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped redn1 (mkReflRedn Representational ps_ty2) ; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 }@@ -1660,16 +1742,12 @@ -- to an irreducible constraint; see typecheck/should_compile/T10494 -- See Note [Decomposing AppTy at representational role] can_eq_app ev s1 t1 s2 t2- | CtDerived {} <- ev- = do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2]- ; stopWith ev "Decomposed [D] AppTy" }-- | CtWanted { ctev_dest = dest } <- ev- = do { co_s <- unifyWanted loc Nominal s1 s2+ | CtWanted { ctev_dest = dest, ctev_rewriters = rewriters } <- ev+ = do { co_s <- unifyWanted rewriters loc Nominal s1 s2 ; let arg_loc | isNextArgVisible s1 = loc | otherwise = updateCtLocOrigin loc toInvisibleOrigin- ; co_t <- unifyWanted arg_loc Nominal t1 t2+ ; co_t <- unifyWanted rewriters arg_loc Nominal t1 t2 ; let co = mkAppCo co_s co_t ; setWantedEq dest co ; stopWith ev "Decomposed [W] AppTy" }@@ -1717,7 +1795,7 @@ = do { traceTcS "Decomposing cast" (vcat [ ppr ev , ppr ty1 <+> text "|>" <+> ppr co1 , ppr ps_ty2 ])- ; new_ev <- rewriteEqEvidence ev swapped+ ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped (mkGReflLeftRedn role ty1 co1) (mkReflRedn role ps_ty2) ; can_eq_nc rewritten new_ev eq_rel ty1 ty1 ty2 ps_ty2 }@@ -1826,18 +1904,13 @@ at role X. Pursuing the details requires exploring three axes:-* Flavour: Given vs. Derived vs. Wanted+* Flavour: Given vs. Wanted * Role: Nominal vs. Representational * TyCon species: datatype vs. newtype vs. data family vs. type family vs. type variable (A type variable isn't a TyCon, of course, but it's convenient to put the AppTy case in the same table.) -Right away, we can say that Derived behaves just as Wanted for the purposes-of decomposition. The difference between Derived and Wanted is the handling of-evidence. Since decomposition in these cases isn't a matter of soundness but of-guessing, we want the same behaviour regardless of evidence.- Here is a table (discussion following) detailing where decomposition of (T s1 ... sn) ~r (T t1 .. tn) is allowed. The first four lines (Data types ... type family) refer@@ -1864,7 +1937,7 @@ {1}: Type families can be injective in some, but not all, of their arguments, so we want to do partial decomposition. This is quite different than the way other decomposition is done, where the decomposed equalities replace the original-one. We thus proceed much like we do with superclasses, emitting new Deriveds+one. We thus proceed much like we do with superclasses, emitting new Wanteds when "decomposing" a partially-injective type family Wanted. Injective type families have no corresponding evidence of their injectivity, so we cannot decompose an injective-type-family Given.@@ -1878,6 +1951,27 @@ {4}: See Note [Decomposing AppTy at representational role] + Because type variables can stand in for newtypes, we conservatively do not+ decompose AppTys over representational equality. Here are two examples that+ demonstrate why we can't:++ 4a: newtype Phant a = MkPhant Int+ [W] alpha Int ~R beta Bool++ If we eventually solve alpha := Phant and beta := Phant, then we can solve+ this equality by unwrapping. But it would have been disastrous to decompose+ the wanted to produce Int ~ Bool, which is definitely insoluble.++ 4b: newtype Age = MkAge Int+ [W] alpha Age ~R Maybe Int++ First, a question: if we know that ty1 ~R ty2, can we conclude that+ a ty1 ~R a ty2? Not for all a. This is precisely why we need role annotations+ on type constructors. So, if we were to decompose, we would need to+ decompose to [W] alpha ~R Maybe and [W] Age ~ Int. On the other hand, if we+ later solve alpha := Maybe, then we would decompose to [W] Age ~R Int, and+ that would be soluble.+ In the implementation of can_eq_nc and friends, we don't directly pattern match using lines like in the tables above, as those tables don't cover all cases (what about PrimTyCon? tuples?). Instead we just ask about injectivity,@@ -2019,14 +2113,11 @@ do { traceTcS "canDecomposableTyConAppOK" (ppr ev $$ ppr eq_rel $$ ppr tc $$ ppr tys1 $$ ppr tys2) ; case ev of- CtDerived {}- -> unifyDeriveds loc tc_roles tys1 tys2-- CtWanted { ctev_dest = dest }+ CtWanted { ctev_dest = dest, ctev_rewriters = rewriters } -- new_locs and tc_roles are both infinite, so -- we are guaranteed that cos has the same length -- as tys1 and tys2- -> do { cos <- zipWith4M unifyWanted new_locs tc_roles tys1 tys2+ -> do { cos <- zipWith4M (unifyWanted rewriters) new_locs tc_roles tys1 tys2 ; setWantedEq dest (mkTyConAppCo role tc cos) } CtGiven { ctev_evar = evar }@@ -2076,14 +2167,14 @@ canEqFailure ev NomEq ty1 ty2 = canEqHardFailure ev ty1 ty2 canEqFailure ev ReprEq ty1 ty2- = do { redn1 <- rewrite ev ty1- ; redn2 <- rewrite ev ty2+ = do { (redn1, rewriters1) <- rewrite ev ty1+ ; (redn2, rewriters2) <- rewrite ev ty2 -- We must rewrite the types before putting them in the -- inert set, so that we are sure to kick them out when -- new equalities become available ; traceTcS "canEqFailure with ReprEq" $ vcat [ ppr ev, ppr redn1, ppr redn2 ]- ; new_ev <- rewriteEqEvidence ev NotSwapped redn1 redn2+ ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 ; continueWith (mkIrredCt ReprEqReason new_ev) } -- | Call when canonicalizing an equality fails with utterly no hope.@@ -2092,9 +2183,9 @@ -- See Note [Make sure that insolubles are fully rewritten] canEqHardFailure ev ty1 ty2 = do { traceTcS "canEqHardFailure" (ppr ty1 $$ ppr ty2)- ; redn1 <- rewrite ev ty1- ; redn2 <- rewrite ev ty2- ; new_ev <- rewriteEqEvidence ev NotSwapped redn1 redn2+ ; (redn1, rewriters1) <- rewrite ev ty1+ ; (redn2, rewriters2) <- rewrite ev ty2+ ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 ; continueWith (mkIrredCt ShapeMismatchReason new_ev) } {-@@ -2149,21 +2240,6 @@ No -- what would the evidence look like? So instead we simply discard this given evidence. --Note [Combining insoluble constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As this point we have an insoluble constraint, like Int~Bool.-- * If it is Wanted, delete it from the cache, so that subsequent- Int~Bool constraints give rise to separate error messages-- * But if it is Derived, DO NOT delete from cache. A class constraint- may get kicked out of the inert set, and then have its functional- dependency Derived constraints generated a second time. In that- case we don't want to get two (or more) error messages by- generating two (or more) insoluble fundep constraints from the same- class constraint.- Note [No top-level newtypes on RHS of representational equalities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we're in this situation:@@ -2189,8 +2265,8 @@ g _ = f (undefined :: F a) For g we get [G] g1 : UnF (F a) ~ a- [WD] w1 : UnF (F beta) ~ beta- [WD] w2 : F a ~ F beta+ [W] w1 : UnF (F beta) ~ beta+ [W] w2 : F a ~ F beta g1 is canonical (CEqCan). It is oriented as above because a is not touchable. See canEqTyVarFunEq.@@ -2205,17 +2281,16 @@ But if w2 is swapped around, to - [D] w3 : F beta ~ F a+ [W] w3 : F beta ~ F a -then (after emitting shadow Deriveds, etc. See GHC.Tc.Solver.Monad-Note [The improvement story and derived shadows]) we'll kick w1 out of the inert+then we'll kick w1 out of the inert set (it mentions the LHS of w3). We then rewrite w1 to - [D] w4 : UnF (F a) ~ beta+ [W] w4 : UnF (F a) ~ beta and then, using g1, to - [D] w5 : a ~ beta+ [W] w5 : a ~ beta at which point we can unify and go on to glory. (This rewriting actually happens all at once, in the call to rewrite during canonicalisation.)@@ -2242,7 +2317,7 @@ = canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 | otherwise- = canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 k1 xi2 ps_xi2 k2+ = canEqCanLHSHetero ev eq_rel swapped lhs1 k1 xi2 k2 where k1 = canEqLHSKind lhs1@@ -2250,40 +2325,42 @@ canEqCanLHSHetero :: CtEvidence -- :: (xi1 :: ki1) ~ (xi2 :: ki2) -> EqRel -> SwapFlag- -> CanEqLHS -> TcType -- xi1, pretty xi1+ -> CanEqLHS -- xi1 -> TcKind -- ki1- -> TcType -> TcType -- xi2, pretty xi2 :: ki2+ -> TcType -- xi2 -> TcKind -- ki2 -> TcS (StopOrContinue Ct)-canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2+canEqCanLHSHetero ev eq_rel swapped lhs1 ki1 xi2 ki2 -- See Note [Equalities with incompatible kinds]- = do { kind_co <- emit_kind_co -- :: ki2 ~N ki1+ = do { (kind_ev, kind_co) <- mk_kind_eq -- :: ki2 ~N ki1 ; let -- kind_co :: (ki2 :: *) ~N (ki1 :: *) (whether swapped or not)- -- co1 :: kind(tv1) ~N ki1- ps_rhs' = ps_xi2 `mkCastTy` kind_co -- :: ki1- lhs_redn = mkReflRedn role xi1- rhs_redn@(Reduction _ rhs')- = mkGReflRightRedn role xi2 kind_co+ rhs_redn = mkGReflRightRedn role xi2 kind_co + -- See Note [Equalities with incompatible kinds], Wrinkle (1)+ -- This will be ignored in rewriteEqEvidence if the work item is a Given+ rewriters = rewriterSetFromCo kind_co+ ; traceTcS "Hetero equality gives rise to kind equality" (ppr kind_co <+> dcolon <+> sep [ ppr ki2, text "~#", ppr ki1 ])- ; type_ev <- rewriteEqEvidence ev swapped lhs_redn rhs_redn+ ; type_ev <- rewriteEqEvidence rewriters ev swapped lhs_redn rhs_redn - -- rewriteEqEvidence carries out the swap, so we're NotSwapped any more- ; canEqCanLHSHomo type_ev eq_rel NotSwapped lhs1 ps_xi1 rhs' ps_rhs' }+ ; emitWorkNC [type_ev] -- delay the type equality until after we've finished+ -- the kind equality, which may unlock things+ -- See Note [Equalities with incompatible kinds]++ ; canEqNC kind_ev NomEq ki2 ki1 } where- emit_kind_co :: TcS CoercionN- emit_kind_co- | CtGiven { ctev_evar = evar } <- ev- = do { let kind_co = maybe_sym $ mkTcKindCo (mkTcCoVarCo evar) -- :: k2 ~ k1- ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co)- ; emitWorkNC [kind_ev]- ; return (ctEvCoercion kind_ev) }+ mk_kind_eq :: TcS (CtEvidence, CoercionN)+ mk_kind_eq = case ev of+ CtGiven { ctev_evar = evar }+ -> do { let kind_co = maybe_sym $ mkTcKindCo (mkTcCoVarCo evar) -- :: k2 ~ k1+ ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co)+ ; return (kind_ev, ctEvCoercion kind_ev) } - | otherwise- = unifyWanted kind_loc Nominal ki2 ki1+ CtWanted { ctev_rewriters = rewriters }+ -> newWantedEq kind_loc rewriters Nominal ki2 ki1 xi1 = canEqLHSType lhs1 loc = ctev_loc ev@@ -2353,7 +2430,7 @@ , TyFamLHS fun_tc2 fun_args2 <- lhs2 = do { traceTcS "canEqCanLHS2 two type families" (ppr lhs1 $$ ppr lhs2) - -- emit derived equalities for injective type families+ -- emit wanted equalities for injective type families ; let inj_eqns :: [TypeEqn] -- TypeEqn = Pair Type inj_eqns | ReprEq <- eq_rel = [] -- injectivity applies only for nom. eqs.@@ -2386,11 +2463,13 @@ | otherwise -- ordinary, non-injective type family = [] - ; unless (isGiven ev) $- mapM_ (unifyDerived (ctEvLoc ev) Nominal) inj_eqns+ ; case ev of+ CtWanted { ctev_rewriters = rewriters } ->+ mapM_ (\ (Pair t1 t2) -> unifyWanted rewriters (ctEvLoc ev) Nominal t1 t2) inj_eqns+ CtGiven {} -> return ()+ -- See Note [No Given/Given fundeps] in GHC.Tc.Solver.Interact ; tclvl <- getTcLevel- ; dflags <- getDynFlags ; let tvs1 = tyCoVarsOfTypes fun_args1 tvs2 = tyCoVarsOfTypes fun_args2 @@ -2401,9 +2480,9 @@ -- If we have F a ~ F (F a), we want to swap. swap_for_occurs- | cterHasNoProblem $ checkTyFamEq dflags fun_tc2 fun_args2+ | cterHasNoProblem $ checkTyFamEq fun_tc2 fun_args2 (mkTyConApp fun_tc1 fun_args1)- , cterHasOccursCheck $ checkTyFamEq dflags fun_tc1 fun_args1+ , cterHasOccursCheck $ checkTyFamEq fun_tc1 fun_args1 (mkTyConApp fun_tc2 fun_args2) = True @@ -2447,10 +2526,9 @@ -> TcS (StopOrContinue Ct) canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv1 rhs- ; dflags <- getDynFlags ; if | case is_touchable of { Untouchable -> False; _ -> True } , cterHasNoProblem $- checkTyVarEq dflags tv1 rhs `cterRemoveProblem` cteTypeFamily+ checkTyVarEq tv1 rhs `cterRemoveProblem` cteTypeFamily -> canEqCanLHSFinish ev eq_rel swapped (TyVarLHS tv1) rhs | otherwise@@ -2477,23 +2555,25 @@ -- guaranteed that tyVarKind lhs == typeKind rhs, for (TyEq:K) -- (TyEq:N) is checked in can_eq_nc', and (TyEq:TV) is handled in canEqCanLHS2 - = do { dflags <- getDynFlags- ; new_ev <- rewriteEqEvidence ev swapped- (mkReflRedn role lhs_ty)- (mkReflRedn role rhs)+ = do {+ -- this performs the swap if necessary+ new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped+ (mkReflRedn role lhs_ty)+ (mkReflRedn role rhs) -- by now, (TyEq:K) is already satisfied ; massert (canEqLHSKind lhs `eqType` tcTypeKind rhs) -- by now, (TyEq:N) is already satisfied (if applicable)- ; massert (not bad_newtype)+ ; assertPprM ty_eq_N_OK $+ vcat [ text "CanEqCanLHSFinish: (TyEq:N) not satisfied"+ , text "rhs:" <+> ppr rhs+ ] -- guarantees (TyEq:OC), (TyEq:F) -- Must do the occurs check even on tyvar/tyvar -- equalities, in case have x ~ (y :: ..x...); this is #12593.- -- This next line checks also for coercion holes (TyEq:H); see- -- Note [Equalities with incompatible kinds]- ; let result0 = checkTypeEq dflags lhs rhs `cterRemoveProblem` cteTypeFamily+ ; let result0 = checkTypeEq lhs rhs `cterRemoveProblem` cteTypeFamily -- type families are OK here -- NB: no occCheckExpand here; see Note [Rewriting synonyms] in GHC.Tc.Solver.Rewrite @@ -2503,10 +2583,7 @@ NomEq -> result0 ReprEq -> cterSetOccursCheckSoluble result0 - reason | result `cterHasOnlyProblem` cteHoleBlocker- = HoleBlockerReason (coercionHolesOfType rhs)- | otherwise- = NonCanonicalReason result+ reason = NonCanonicalReason result ; if cterHasNoProblem result then do { traceTcS "CEqCan" (ppr lhs $$ ppr rhs)@@ -2527,14 +2604,15 @@ ; traceTcS "new RHS:" (ppr new_rhs) -- This check is Detail (1) in the Note- ; if cterHasOccursCheck (checkTyVarEq dflags lhs_tv new_rhs)+ ; if cterHasOccursCheck (checkTyVarEq lhs_tv new_rhs) then do { traceTcS "Note [Type variable cycles] Detail (1)" (ppr new_rhs) ; continueWith (mkIrredCt reason new_ev) } else do { -- See Detail (6) of Note [Type variable cycles]- new_new_ev <- rewriteEqEvidence new_ev NotSwapped+ new_new_ev <- rewriteEqEvidence emptyRewriterSet+ new_ev NotSwapped (mkReflRedn Nominal lhs_ty) rhs_redn @@ -2547,12 +2625,20 @@ lhs_ty = canEqLHSType lhs - -- This is about (TyEq:N)- bad_newtype | ReprEq <- eq_rel- , Just tc <- tyConAppTyCon_maybe rhs- = isNewTyCon tc- | otherwise- = False+ -- This is about (TyEq:N): check that we don't have a newtype+ -- whose constructor is in scope at the top-level of the RHS.+ ty_eq_N_OK :: TcS Bool+ ty_eq_N_OK+ | ReprEq <- eq_rel+ , Just tc <- tyConAppTyCon_maybe rhs+ , Just con <- newTyConDataCon_maybe tc+ -- #21010: only a problem if the newtype constructor is in scope+ -- yet we didn't rewrite it away.+ = do { rdr_env <- getGlobalRdrEnvTcS+ ; let con_in_scope = isJust $ lookupGRE_Name rdr_env (dataConName con)+ ; return $ not con_in_scope }+ | otherwise+ = return True -- | Solve a reflexive equality constraint canEqReflexive :: CtEvidence -- ty ~ ty@@ -2572,7 +2658,7 @@ -> TcS CtEvidence -- :: (lhs |> sym mco) ~ rhs -- result is independent of SwapFlag rewriteCastedEquality ev eq_rel swapped lhs rhs mco- = rewriteEqEvidence ev swapped lhs_redn rhs_redn+ = rewriteEqEvidence emptyRewriterSet ev swapped lhs_redn rhs_redn where lhs_redn = mkGReflRightMRedn role lhs sym_mco rhs_redn = mkGReflLeftMRedn role rhs mco@@ -2591,78 +2677,38 @@ [X] (tv :: k1) ~ (rhs :: k2) -(where [X] is [G], [W], or [D]), we go to-- [noDerived X] co :: k2 ~ k1- [X] (tv :: k1) ~ ((rhs |> co) :: k1)--where+(where [X] is [G] or [W]), we go to - noDerived G = G- noDerived _ = W+ [X] co :: k2 ~ k1+ [X] (tv :: k1) ~ ((rhs |> co) :: k1) -For reasons described in Wrinkle (2) below, we want the [X] constraint to be "blocked";-that is, it should be put aside, and not used to rewrite any other constraint,-until the kind-equality on which it depends (namely 'co' above) is solved.-To achieve this-* The [X] constraint is a CIrredCan-* With a cc_reason of HoleBlockerReason bchs-* Where 'bchs' is the set of "blocking coercion holes". The blocking coercion- holes are the free coercion holes of [X]'s type-* When all the blocking coercion holes in the CIrredCan are filled (solved),- we convert [X] to a CNonCanonical and put it in the work list.-All this is described in more detail in Wrinkle (2).+We carry on with the *kind equality*, not the type equality, because+solving the former may unlock the latter. This choice is made in+canEqCanLHSHetero. It is important: otherwise, T13135 loops. Wrinkles: - (1) The noDerived step is because Derived equalities have no evidence.- And yet we absolutely need evidence to be able to proceed here.- Given evidence will use the KindCo coercion; Wanted evidence will- be a coercion hole. Even a Derived hetero equality begets a Wanted- kind equality.-- (2) Though it would be sound to do so, we must not mark the rewritten Wanted- [W] (tv :: k1) ~ ((rhs |> co) :: k1)- as canonical in the inert set. In particular, we must not unify tv.- If we did, the Wanted becomes a Given (effectively), and then can- rewrite other Wanteds. But that's bad: See Note [Wanteds do not rewrite Wanteds]- in GHC.Tc.Types.Constraint. The problem is about poor error messages. See #11198 for- tales of destruction.+ (1) When X is W, the new type-level wanted is effectively rewritten by the+ kind-level one. We thus include the kind-level wanted in the RewriterSet+ for the type-level one. See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint.+ This is done in canEqCanLHSHetero. - So, we have an invariant on CEqCan (TyEq:H) that the RHS does not have- any coercion holes. This is checked in checkTypeEq. Any equalities that- have such an RHS are turned into CIrredCans with a HoleBlockerReason. We also- must be sure to kick out any such CIrredCan constraints that mention coercion holes- when those holes get filled in, so that the unification step can now proceed.+ (2) If we have [W] w :: alpha ~ (rhs |> co_hole), should we unify alpha? No.+ The problem is that the wanted w is effectively rewritten by another wanted,+ and unifying alpha effectively promotes this wanted to a given. Doing so+ means we lose track of the rewriter set associated with the wanted. - The kicking out is done in kickOutAfterFillingCoercionHole, and the inerts- are stored in the inert_blocked field of InertCans.+ On the other hand, w is perfectly suitable for rewriting, because of the+ way we carefully track rewriter sets. - However, we must be careful: we kick out only when no coercion holes are- left. The holes in the type are stored in the HoleBlockerReason CtIrredReason.- The extra check that there are no more remaining holes avoids- needless work when rewriting evidence (which fills coercion holes) and- aids efficiency.+ We thus allow w to be a CEqCan, but we prevent unification. See+ Note [Unification preconditions] in GHC.Tc.Utils.Unify. - Moreover, kicking out when there are remaining unfilled holes can- cause a loop in the solver in this case:- [W] w1 :: (ty1 :: F a) ~ (ty2 :: s)- After canonicalisation, we discover that this equality is heterogeneous.- So we emit- [W] co_abc :: F a ~ s- and preserve the original as- [W] w2 :: (ty1 |> co_abc) ~ ty2 (blocked on co_abc)- Then, co_abc comes becomes the work item. It gets swapped in- canEqCanLHS2 and then back again in canEqTyVarFunEq. We thus get- co_abc := sym co_abd, and then co_abd := sym co_abe, with- [W] co_abe :: F a ~ s- This process has filled in co_abc. Suppose w2 were kicked out.- When it gets processed,- would get this whole chain going again. The solution is to- kick out a blocked constraint only when the result of filling- in the blocking coercion involves no further blocking coercions.- Alternatively, we could be careful not to do unnecessary swaps during- canonicalisation, but that seems hard to do, in general.+ The only tricky part is that we must later indeed unify if/when the kind-level+ wanted gets solved. This is done in kickOutAfterFillingCoercionHole,+ which kicks out all equalities whose RHS mentions the filled-in coercion hole.+ Note that it looks for type family equalities, too, because of the use of+ unifyTest in canEqTyVarFunEq. (3) Suppose we have [W] (a :: k1) ~ (rhs :: k2). We duly follow the algorithm detailed here, producing [W] co :: k2 ~ k1, and adding@@ -2682,25 +2728,6 @@ cast appears opposite a tyvar. This is implemented in the cast case of can_eq_nc'. - (4) Reporting an error for a constraint that is blocked with HoleBlockerReason- is hard: what would we say to users? And we don't- really need to report, because if a constraint is blocked, then- there is unsolved wanted blocking it; that unsolved wanted will- be reported. We thus push such errors to the bottom of the queue- in the error-reporting code; they should never be printed.-- (4a) It would seem possible to do this filtering just based on the- presence of a blocking coercion hole. However, this is no good,- as it suppresses e.g. no-instance-found errors. We thus record- a CtIrredReason in CIrredCan and filter based on this status.- This happened in T14584. An alternative approach is to expressly- look for *equalities* with blocking coercion holes, but actually- recording the blockage in a status field seems nicer.-- (4b) The error message might be printed with -fdefer-type-errors,- so it still must exist. This is the only reason why there is- a message at all. Otherwise, we could simply do nothing.- Historical note: We used to do this via emitting a Derived kind equality and then parking@@ -2760,7 +2787,7 @@ or (typecheck/should_compile/T19682b): instance C (a -> b)- *[WD] alpha ~ (Arg alpha -> Res alpha)+ *[W] alpha ~ (Arg alpha -> Res alpha) [W] C alpha In order to solve the final Wanted, we must use the starred constraint@@ -2783,17 +2810,15 @@ or instance C (a -> b)- [WD] alpha ~ (cbv1 -> cbv2)- [WD] Arg alpha ~ cbv1- [WD] Res alpha ~ cbv2+ [W] alpha ~ (cbv1 -> cbv2)+ [W] Arg alpha ~ cbv1+ [W] Res alpha ~ cbv2 [W] C alpha This transformation (creating the new types and emitting new equality constraints) is done in breakTyVarCycle_maybe. -The details depend on whether we're working with a Given or a Derived.-(Note that the Wanteds are really WDs, above. This is because Wanteds-are not used for rewriting.)+The details depend on whether we're working with a Given or a Wanted. Given -----@@ -2837,19 +2862,19 @@ * The evidence for the new `F a ~ cbv` constraint is Refl, because we know this fill-in is ultimately going to happen. -Wanted/Derived---------------+Wanted+------ The fresh cycle-breaker variables here must actually be normal, touchable metavariables. That is, they are TauTvs. Nothing at all unusual. Repeating the example from above, we have - *[WD] alpha ~ (Arg alpha -> Res alpha)+ *[W] alpha ~ (Arg alpha -> Res alpha) and we turn this into - *[WD] alpha ~ (cbv1 -> cbv2)- [WD] Arg alpha ~ cbv1- [WD] Res alpha ~ cbv2+ *[W] alpha ~ (cbv1 -> cbv2)+ [W] Arg alpha ~ cbv1+ [W] Res alpha ~ cbv2 where cbv1 and cbv2 are fresh TauTvs. Why TauTvs? See [Why TauTvs] below. @@ -2863,11 +2888,11 @@ Note): instance C (a -> b)- [WD] Arg (cbv1 -> cbv2) ~ cbv1- [WD] Res (cbv1 -> cbv2) ~ cbv2+ [W] Arg (cbv1 -> cbv2) ~ cbv1+ [W] Res (cbv1 -> cbv2) ~ cbv2 [W] C (cbv1 -> cbv2) -The first two WD constraints reduce to reflexivity and are discarded,+The first two W constraints reduce to reflexivity and are discarded, and the last is easily soluble. [Why TauTvs]:@@ -2885,43 +2910,43 @@ AllEqF '[] '[] = () AllEqF (x : xs) (y : ys) = (x ~ y, AllEq xs ys) - [WD] alpha ~ (Head alpha : Tail alpha)- [WD] AllEqF '[Bool] alpha+ [W] alpha ~ (Head alpha : Tail alpha)+ [W] AllEqF '[Bool] alpha Without the logic detailed in this Note, we're stuck here, as AllEqF cannot reduce and alpha cannot unify. Let's instead apply our cycle-breaker approach, just as described above. We thus invent cbv1 and cbv2 and unify alpha := cbv1 -> cbv2, yielding (after zonking) - [WD] Head (cbv1 : cbv2) ~ cbv1- [WD] Tail (cbv1 : cbv2) ~ cbv2- [WD] AllEqF '[Bool] (cbv1 : cbv2)+ [W] Head (cbv1 : cbv2) ~ cbv1+ [W] Tail (cbv1 : cbv2) ~ cbv2+ [W] AllEqF '[Bool] (cbv1 : cbv2) -The first two WD constraints simplify to reflexivity and are discarded.+The first two W constraints simplify to reflexivity and are discarded. But the last reduces: - [WD] Bool ~ cbv1- [WD] AllEq '[] cbv2+ [W] Bool ~ cbv1+ [W] AllEq '[] cbv2 The first of these is solved by unification: cbv1 := Bool. The second is solved by the instance for AllEq to become - [WD] AllEqF '[] cbv2- [WD] SameShapeAs '[] cbv2+ [W] AllEqF '[] cbv2+ [W] SameShapeAs '[] cbv2 While the first of these is stuck, the second makes progress, to lead to - [WD] AllEqF '[] cbv2- [WD] cbv2 ~ '[]+ [W] AllEqF '[] cbv2+ [W] cbv2 ~ '[] This second constraint is solved by unification: cbv2 := '[]. We now have - [WD] AllEqF '[] '[]+ [W] AllEqF '[] '[] which reduces to - [WD] ()+ [W] () which is trivially satisfiable. Hooray! @@ -2938,8 +2963,7 @@ - and a nominal equality - and either - a Given flavour (but see also Detail (7) below)- - a Wanted/Derived or just plain Derived flavour, with a touchable metavariable- on the left+ - a Wanted flavour, with a touchable metavariable on the left We don't use this trick for representational equalities, as there is no concrete use case where it is helpful (unlike for nominal equalities).@@ -3058,7 +3082,7 @@ We track these equalities by giving them a special CtOrigin, CycleBreakerOrigin. This works for both Givens and WDs, as- we need the logic in the WD case for e.g. typecheck/should_fail/T17139.+ we need the logic in the W case for e.g. typecheck/should_fail/T17139. (8) We really want to do this all only when there is a soluble occurs-check failure, not when other problems arise (such as an impredicative@@ -3104,7 +3128,9 @@ ContinueWith ct -> tcs2 ct } infixr 0 `andWhenContinue` -- allow chaining with ($) -rewriteEvidence :: CtEvidence -- ^ old evidence+rewriteEvidence :: RewriterSet -- ^ See Note [Wanteds rewrite Wanteds]+ -- in GHC.Tc.Types.Constraint+ -> CtEvidence -- ^ old evidence -> Reduction -- ^ new predicate + coercion, of type <type of old evidence> ~ new predicate -> TcS (StopOrContinue CtEvidence) -- Returns Just new_ev iff either (i) 'co' is reflexivity@@ -3114,7 +3140,7 @@ rewriteEvidence old_ev new_pred co Main purpose: create new evidence for new_pred; unless new_pred is cached already-* Returns a new_ev : new_pred, with same wanted/given/derived flag as old_ev+* Returns a new_ev : new_pred, with same wanted/given flag as old_ev * If old_ev was wanted, create a binding for old_ev, in terms of new_ev * If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev * Returns Nothing if new_ev is already cached@@ -3123,7 +3149,7 @@ flavour of same flavor ------------------------------------------------------------------- Wanted Already solved or in inert Nothing- or Derived Not Just new_evidence+ Not Just new_evidence Given Already in inert Nothing Not Just new_evidence@@ -3138,37 +3164,33 @@ The rewriter preserves type synonyms, so they should appear in new_pred as well as in old_pred; that is important for good error messages.++If we are rewriting with Refl, then there are no new rewriters to add to+the rewriter set. We check this with an assertion. -} -rewriteEvidence old_ev@(CtDerived {}) (Reduction _co new_pred)- = -- If derived, don't even look at the coercion.- -- This is very important, DO NOT re-order the equations for- -- rewriteEvidence to put the isTcReflCo test first!- -- Why? Because for *Derived* constraints, c, the coercion, which- -- was produced by rewriting, may contain suspended calls to- -- (ctEvExpr c), which fails for Derived constraints.- -- (Getting this wrong caused #7384.)- continueWith (setCtEvPredType old_ev new_pred)--rewriteEvidence old_ev (Reduction co new_pred)+rewriteEvidence rewriters old_ev (Reduction co new_pred) | isTcReflCo co -- See Note [Rewriting with Refl]- = continueWith (setCtEvPredType old_ev new_pred)+ = assert (isEmptyRewriterSet rewriters) $+ continueWith (setCtEvPredType old_ev new_pred) -rewriteEvidence ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) (Reduction co new_pred)- = do { new_ev <- newGivenEvVar loc (new_pred, new_tm)+rewriteEvidence rewriters ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc })+ (Reduction co new_pred)+ = assert (isEmptyRewriterSet rewriters) $ -- this is a Given, not a wanted+ do { new_ev <- newGivenEvVar loc (new_pred, new_tm) ; continueWith new_ev } where -- mkEvCast optimises ReflCo new_tm = mkEvCast (evId old_evar) (tcDowngradeRole Representational (ctEvRole ev) co) -rewriteEvidence ev@(CtWanted { ctev_dest = dest- , ctev_nosh = si- , ctev_loc = loc }) (Reduction co new_pred)- = do { mb_new_ev <- newWanted_SI si loc new_pred- -- The "_SI" variant ensures that we make a new Wanted- -- with the same shadow-info as the existing one (#16735)+rewriteEvidence new_rewriters+ ev@(CtWanted { ctev_dest = dest+ , ctev_loc = loc+ , ctev_rewriters = rewriters })+ (Reduction co new_pred)+ = do { mb_new_ev <- newWanted loc rewriters' new_pred ; massert (tcCoercionRole co == ctEvRole ev) ; setWantedEvTerm dest (mkEvCast (getEvExpr mb_new_ev)@@ -3176,9 +3198,14 @@ ; case mb_new_ev of Fresh new_ev -> continueWith new_ev Cached _ -> stopWith ev "Cached wanted" }+ where+ rewriters' = rewriters S.<> new_rewriters -rewriteEqEvidence :: CtEvidence -- Old evidence :: olhs ~ orhs (not swapped)+rewriteEqEvidence :: RewriterSet -- New rewriters+ -- See GHC.Tc.Types.Constraint+ -- Note [Wanteds rewrite Wanteds]+ -> CtEvidence -- Old evidence :: olhs ~ orhs (not swapped) -- or orhs ~ olhs (swapped) -> SwapFlag -> Reduction -- lhs_co :: olhs ~ nlhs@@ -3199,10 +3226,7 @@ -- w : orhs ~ olhs = rhs_co ; sym w1 ; sym lhs_co -- -- It's all a form of rewriteEvidence, specialised for equalities-rewriteEqEvidence old_ev swapped (Reduction lhs_co nlhs) (Reduction rhs_co nrhs)- | CtDerived {} <- old_ev -- Don't force the evidence for a Derived- = return (setCtEvPredType old_ev new_pred)-+rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reduction rhs_co nrhs) | NotSwapped <- swapped , isTcReflCo lhs_co -- See Note [Rewriting with Refl] , isTcReflCo rhs_co@@ -3214,17 +3238,21 @@ `mkTcTransCo` rhs_co) ; newGivenEvVar loc' (new_pred, new_tm) } - | CtWanted { ctev_dest = dest, ctev_nosh = si } <- old_ev- = do { (new_ev, hole_co) <- newWantedEq_SI si loc'- (ctEvRole old_ev) nlhs nrhs- -- The "_SI" variant ensures that we make a new Wanted- -- with the same shadow-info as the existing one (#16735)+ | CtWanted { ctev_dest = dest+ , ctev_rewriters = rewriters } <- old_ev+ , let rewriters' = rewriters S.<> new_rewriters+ = do { (new_ev, hole_co) <- newWantedEq loc' rewriters'+ (ctEvRole old_ev) nlhs nrhs ; let co = maybeTcSymCo swapped $ lhs_co `mkTransCo` hole_co `mkTransCo` mkTcSymCo rhs_co ; setWantedEq dest co- ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co])+ ; traceTcS "rewriteEqEvidence" (vcat [ ppr old_ev+ , ppr nlhs+ , ppr nrhs+ , ppr co+ , ppr new_rewriters ]) ; return new_ev } #if __GLASGOW_HASKELL__ <= 810@@ -3247,11 +3275,10 @@ * * ************************************************************************ -Note [unifyWanted and unifyDerived]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [unifyWanted]+~~~~~~~~~~~~~~~~~~ When decomposing equalities we often create new wanted constraints for (s ~ t). But what if s=t? Then it'd be faster to return Refl right away.-Similar remarks apply for Derived. Rather than making an equality test (which traverses the structure of the type, perhaps fruitlessly), unifyWanted traverses the common structure, and@@ -3260,32 +3287,32 @@ to reflect it. -} -unifyWanted :: CtLoc -> Role- -> TcType -> TcType -> TcS Coercion+unifyWanted :: RewriterSet -> CtLoc+ -> Role -> TcType -> TcType -> TcS Coercion -- Return coercion witnessing the equality of the two types, -- emitting new work equalities where necessary to achieve that -- Very good short-cut when the two types are equal, or nearly so--- See Note [unifyWanted and unifyDerived]+-- See Note [unifyWanted] -- The returned coercion's role matches the input parameter-unifyWanted loc Phantom ty1 ty2- = do { kind_co <- unifyWanted loc Nominal (tcTypeKind ty1) (tcTypeKind ty2)+unifyWanted rewriters loc Phantom ty1 ty2+ = do { kind_co <- unifyWanted rewriters loc Nominal (tcTypeKind ty1) (tcTypeKind ty2) ; return (mkPhantomCo kind_co ty1 ty2) } -unifyWanted loc role orig_ty1 orig_ty2+unifyWanted rewriters loc role orig_ty1 orig_ty2 = go orig_ty1 orig_ty2 where go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2 go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' go (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2)- = do { co_s <- unifyWanted loc role s1 s2- ; co_t <- unifyWanted loc role t1 t2- ; co_w <- unifyWanted loc Nominal w1 w2+ = do { co_s <- unifyWanted rewriters loc role s1 s2+ ; co_t <- unifyWanted rewriters loc role t1 t2+ ; co_w <- unifyWanted rewriters loc Nominal w1 w2 ; return (mkFunCo role co_w co_s co_t) } go (TyConApp tc1 tys1) (TyConApp tc2 tys2) | tc1 == tc2, tys1 `equalLength` tys2 , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality- = do { cos <- zipWith3M (unifyWanted loc)+ = do { cos <- zipWith3M (unifyWanted rewriters loc) (tyConRolesX role tc1) tys1 tys2 ; return (mkTyConAppCo role tc1 cos) } @@ -3308,48 +3335,4 @@ bale_out ty1 ty2 | ty1 `tcEqType` ty2 = return (mkTcReflCo role ty1) -- Check for equality; e.g. a ~ a, or (m a) ~ (m a)- | otherwise = emitNewWantedEq loc role orig_ty1 orig_ty2--unifyDeriveds :: CtLoc -> [Role] -> [TcType] -> [TcType] -> TcS ()--- See Note [unifyWanted and unifyDerived]-unifyDeriveds loc roles tys1 tys2 = zipWith3M_ (unify_derived loc) roles tys1 tys2--unifyDerived :: CtLoc -> Role -> Pair TcType -> TcS ()--- See Note [unifyWanted and unifyDerived]-unifyDerived loc role (Pair ty1 ty2) = unify_derived loc role ty1 ty2--unify_derived :: CtLoc -> Role -> TcType -> TcType -> TcS ()--- Create new Derived and put it in the work list--- Should do nothing if the two types are equal--- See Note [unifyWanted and unifyDerived]-unify_derived _ Phantom _ _ = return ()-unify_derived loc role orig_ty1 orig_ty2- = go orig_ty1 orig_ty2- where- go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2- go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2'-- go (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2)- = do { unify_derived loc role s1 s2- ; unify_derived loc role t1 t2- ; unify_derived loc Nominal w1 w2 }- go (TyConApp tc1 tys1) (TyConApp tc2 tys2)- | tc1 == tc2, tys1 `equalLength` tys2- , isInjectiveTyCon tc1 role- = unifyDeriveds loc (tyConRolesX role tc1) tys1 tys2- go ty1@(TyVarTy tv) ty2- = do { mb_ty <- isFilledMetaTyVar_maybe tv- ; case mb_ty of- Just ty1' -> go ty1' ty2- Nothing -> bale_out ty1 ty2 }- go ty1 ty2@(TyVarTy tv)- = do { mb_ty <- isFilledMetaTyVar_maybe tv- ; case mb_ty of- Just ty2' -> go ty1 ty2'- Nothing -> bale_out ty1 ty2 }- go ty1 ty2 = bale_out ty1 ty2-- bale_out ty1 ty2- | ty1 `tcEqType` ty2 = return ()- -- Check for equality; e.g. a ~ a, or (m a) ~ (m a)- | otherwise = emitNewDerivedEq loc role orig_ty1 orig_ty2+ | otherwise = emitNewWantedEq loc rewriters role orig_ty1 orig_ty2
compiler/GHC/Tc/Solver/Interact.hs view
@@ -4,7 +4,7 @@ module GHC.Tc.Solver.Interact ( solveSimpleGivens, -- Solves [Ct]- solveSimpleWanteds, -- Solves Cts+ solveSimpleWanteds -- Solves Cts ) where import GHC.Prelude@@ -31,7 +31,6 @@ import GHC.Tc.Types.Evidence import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Tc.Types import GHC.Tc.Types.Constraint@@ -45,17 +44,18 @@ import GHC.Utils.Monad ( concatMapM, foldlM ) import GHC.Core-import Data.List( partition, deleteFirstsBy )+import Data.List( deleteFirstsBy )+import Data.Function ( on ) import GHC.Types.SrcLoc import GHC.Types.Var.Env +import qualified Data.Semigroup as S import Control.Monad import GHC.Data.Pair (Pair(..)) import GHC.Types.Unique( hasKey ) import GHC.Driver.Session import GHC.Utils.Misc import qualified GHC.LanguageExtensions as LangExt-import Data.List.NonEmpty ( NonEmpty(..) ) import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe@@ -187,9 +187,9 @@ ; if null solvers then return [] else do { givens <- getInertGivens ; if null givens then return [] else- do { p <- runTcPluginSolvers solvers (givens,[],[])- ; let (solved_givens, _, _) = pluginSolvedCts p- insols = pluginBadCts p+ do { p <- runTcPluginSolvers solvers (givens,[])+ ; let (solved_givens, _) = pluginSolvedCts p+ insols = pluginBadCts p ; updInertCans (removeInertCts solved_givens) ; updInertIrreds (\irreds -> extendCtsList irreds insols) ; return (pluginNewCts p) } } }@@ -208,22 +208,20 @@ ; if null solvers then return (False, wc) else do { given <- getInertGivens- ; simples1 <- zonkSimples simples1 -- Plugin requires zonked inputs- ; let (wanted, derived) = partition isWantedCt (bagToList simples1)- ; p <- runTcPluginSolvers solvers (given, derived, wanted)- ; let (_, _, solved_wanted) = pluginSolvedCts p- (_, unsolved_derived, unsolved_wanted) = pluginInputCts p+ ; wanted <- zonkSimples simples1 -- Plugin requires zonked inputs+ ; p <- runTcPluginSolvers solvers (given, bagToList wanted)+ ; let (_, solved_wanted) = pluginSolvedCts p+ (_, unsolved_wanted) = pluginInputCts p new_wanted = pluginNewCts p insols = pluginBadCts p -- SLPJ: I'm deeply suspicious of this--- ; updInertCans (removeInertCts $ solved_givens ++ solved_deriveds)+-- ; updInertCans (removeInertCts $ solved_givens) ; mapM_ setEv solved_wanted ; return ( notNull (pluginNewCts p) , wc { wc_simple = listToBag new_wanted `andCts` listToBag unsolved_wanted `andCts`- listToBag unsolved_derived `andCts` listToBag insols } ) } } where setEv :: (EvTerm,Ct) -> TcS ()@@ -231,11 +229,11 @@ CtWanted { ctev_dest = dest } -> setWantedEvTerm dest ev _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!" --- | A triple of (given, derived, wanted) constraints to pass to plugins-type SplitCts = ([Ct], [Ct], [Ct])+-- | A pair of (given, wanted) constraints to pass to plugins+type SplitCts = ([Ct], [Ct]) --- | A solved triple of constraints, with evidence for wanteds-type SolvedCts = ([Ct], [Ct], [(EvTerm,Ct)])+-- | A solved pair of constraints, with evidence for wanteds+type SolvedCts = ([Ct], [(EvTerm,Ct)]) -- | Represents collections of constraints generated by typechecker -- plugins@@ -255,7 +253,7 @@ getTcPluginSolvers = do { tcg_env <- getGblEnv; return (tcg_tc_plugin_solvers tcg_env) } --- | Starting from a triple of (given, derived, wanted) constraints,+-- | Starting from a pair of (given, wanted) constraints, -- invoke each of the typechecker constraint-solving plugins in turn and return -- -- * the remaining unmodified constraints,@@ -274,7 +272,7 @@ where do_plugin :: TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress do_plugin p solver = do- result <- runTcPluginTcS (uncurry3 solver (pluginInputCts p))+ result <- runTcPluginTcS (uncurry solver (pluginInputCts p)) return $ progress p result progress :: TcPluginProgress -> TcPluginSolveResult -> TcPluginProgress@@ -291,11 +289,11 @@ , pluginBadCts = bad_cts ++ pluginBadCts p } - initialProgress = TcPluginProgress all_cts ([], [], []) [] []+ initialProgress = TcPluginProgress all_cts ([], []) [] [] discard :: [Ct] -> SplitCts -> SplitCts- discard cts (xs, ys, zs) =- (xs `without` cts, ys `without` cts, zs `without` cts)+ discard cts (xs, ys) =+ (xs `without` cts, ys `without` cts) without :: [Ct] -> [Ct] -> [Ct] without = deleteFirstsBy eqCt@@ -308,10 +306,9 @@ add xs scs = foldl' addOne scs xs addOne :: SolvedCts -> (EvTerm,Ct) -> SolvedCts- addOne (givens, deriveds, wanteds) (ev,ct) = case ctEvidence ct of- CtGiven {} -> (ct:givens, deriveds, wanteds)- CtDerived{} -> (givens, ct:deriveds, wanteds)- CtWanted {} -> (givens, deriveds, (ev,ct):wanteds)+ addOne (givens, wanteds) (ev,ct) = case ctEvidence ct of+ CtGiven {} -> (ct:givens, wanteds)+ CtWanted {} -> (givens, (ev,ct):wanteds) type WorkItem = Ct@@ -414,7 +411,7 @@ then the inert item must Given or, equivalently, If the work-item is Given,- and the inert item is Wanted/Derived+ and the inert item is Wanted then there is no reaction -} @@ -441,30 +438,10 @@ -- (if the latter is Wanted; just discard it if not) | KeepWork -- Keep the work item, and solve the inert item from it - | KeepBoth -- See Note [KeepBoth]- instance Outputable InteractResult where- ppr KeepBoth = text "keep both" ppr KeepInert = text "keep inert" ppr KeepWork = text "keep work-item" -{- Note [KeepBoth]-~~~~~~~~~~~~~~~~~~-Consider- Inert: [WD] C ty1 ty2- Work item: [D] C ty1 ty2--Here we can simply drop the work item. But what about- Inert: [W] C ty1 ty2- Work item: [D] C ty1 ty2--Here we /cannot/ drop the work item, becuase we lose the [D] form, and-that is essential for e.g. fundeps, see isImprovable. We could zap-the inert item to [WD], but the simplest thing to do is simply to keep-both. (They probably started as [WD] and got split; this is relatively-rare and it doesn't seem worth trying to put them back together again.)--}- solveOneFromTheOther :: CtEvidence -- Inert (Dict or Irred) -> CtEvidence -- WorkItem (same predicate as inert) -> TcS InteractResult@@ -477,38 +454,23 @@ -- two wanteds into one by solving one from the other solveOneFromTheOther ev_i ev_w- | CtDerived {} <- ev_w -- Work item is Derived- = case ev_i of- CtWanted { ctev_nosh = WOnly } -> return KeepBoth- _ -> return KeepInert-- | CtDerived {} <- ev_i -- Inert item is Derived- = case ev_w of- CtWanted { ctev_nosh = WOnly } -> return KeepBoth- _ -> return KeepWork- -- The ev_w is inert wrt earlier inert-set items,- -- so it's safe to continue on from this point-- -- After this, neither ev_i or ev_w are Derived | CtWanted { ctev_loc = loc_w } <- ev_w , prohibitedSuperClassSolve loc_i loc_w = -- inert must be Given do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w) ; return KeepWork } - | CtWanted { ctev_nosh = nosh_w } <- ev_w+ | CtWanted {} <- ev_w -- Inert is Given or Wanted- = case ev_i of- CtWanted { ctev_nosh = WOnly }- | WDeriv <- nosh_w -> return KeepWork- _ -> return KeepInert- -- Consider work item [WD] C ty1 ty2- -- inert item [W] C ty1 ty2- -- Then we must keep the work item. But if the- -- work item was [W] C ty1 ty2- -- then we are free to discard the work item in favour of inert- -- Remember, no Deriveds at this point+ = return $ case ev_i of+ CtWanted {} -> choose_better_loc+ -- both are Wanted; choice of which to keep is+ -- arbitrary. So we look at the context to choose+ -- which would make a better error message + _ -> KeepInert+ -- work is Wanted; inert is Given: easy choice.+ -- From here on the work-item is Given | CtWanted { ctev_loc = loc_i } <- ev_i@@ -536,6 +498,27 @@ lvl_i = ctLocLevel loc_i lvl_w = ctLocLevel loc_w + choose_better_loc+ -- if only one is a WantedSuperclassOrigin (arising from expanding+ -- a Wanted class constraint), keep the other: wanted superclasses+ -- may be unexpected by users+ | is_wanted_superclass_loc loc_i+ , not (is_wanted_superclass_loc loc_w) = KeepWork++ | not (is_wanted_superclass_loc loc_i)+ , is_wanted_superclass_loc loc_w = KeepInert++ -- otherwise, just choose the lower span+ -- reason: if we have something like (abs 1) (where the+ -- Num constraint cannot be satisfied), it's better to+ -- get an error about abs than about 1.+ -- This test might become more elaborate if we see an+ -- opportunity to improve the error messages+ | ((<) `on` ctLocSpan) loc_i loc_w = KeepInert+ | otherwise = KeepWork++ is_wanted_superclass_loc = isWantedSuperclassOrigin . ctLocOrigin+ different_level_strategy -- Both Given | isIPLikePred pred = if lvl_w > lvl_i then KeepWork else KeepInert | otherwise = if lvl_w > lvl_i then KeepInert else KeepWork@@ -666,8 +649,6 @@ -- For insolubles, don't allow the constraint to be dropped -- which can happen with solveOneFromTheOther, so that -- we get distinct error messages with -fdefer-type-errors- -- See Note [Do not add duplicate derived insolubles]- , not (isDroppableCt workItem) = continueWith workItem | let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w@@ -677,7 +658,6 @@ = do { what_next <- solveOneFromTheOther ev_i ev_w ; traceTcS "iteractIrred" (ppr workItem $$ ppr what_next $$ ppr ct_i) ; case what_next of- KeepBoth -> continueWith workItem KeepInert -> do { setEvBindIfWanted ev_w (swap_me swap ev_i) ; return (Stop ev_w (text "Irred equal" <+> parens (ppr what_next))) } KeepWork -> do { setEvBindIfWanted ev_i (swap_me swap ev_w)@@ -736,56 +716,6 @@ lookup, findMatchingIrreds spots the equality case, and matches either way around. It has to return a swap-flag so we can generate evidence that is the right way round too.--Note [Do not add duplicate derived insolubles]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In general we *must* add an insoluble (Int ~ Bool) even if there is-one such there already, because they may come from distinct call-sites. Not only do we want an error message for each, but with--fdefer-type-errors we must generate evidence for each. But for-*derived* insolubles, we only want to report each one once. Why?--(a) A constraint (C r s t) where r -> s, say, may generate the same fundep- equality many times, as the original constraint is successively rewritten.--(b) Ditto the successive iterations of the main solver itself, as it traverses- the constraint tree. See example below.--Also for *given* insolubles we may get repeated errors, as we-repeatedly traverse the constraint tree. These are relatively rare-anyway, so removing duplicates seems ok. (Alternatively we could take-the SrcLoc into account.)--Note that the test does not need to be particularly efficient because-it is only used if the program has a type error anyway.--Example of (b): assume a top-level class and instance declaration:-- class D a b | a -> b- instance D [a] [a]--Assume we have started with an implication:-- forall c. Eq c => { wc_simple = [W] D [c] c }--which we have simplified to, with a Derived constraing coming from-D's functional dependency:-- forall c. Eq c => { wc_simple = [W] D [c] c [W]- [D] (c ~ [c]) }--When iterating the solver, we might try to re-solve this-implication. If we do not do a dropDerivedWC, then we will end up-trying to solve the following constraints the second time:-- [W] (D [c] c)- [D] (c ~ [c])--which will result in two Deriveds to end up in the insoluble set:-- wc_simple = [W] D [c] c- [D] (c ~ [c])- [D] (c ~ [c]) -} {-@@ -1000,6 +930,68 @@ and to solve G2 we may need H. If we don't spot this sharing we may solve H twice; and if this pattern repeats we may get exponentially bad behaviour.++Note [No Given/Given fundeps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not create constraints from:+* Given/Given interactions via functional dependencies or type family+ injectivity annotations.+* Given/instance fundep interactions via functional dependencies or+ type family injectivity annotations.++In this Note, all these interactions are called just "fundeps".++We ingore such fundeps for several reasons:++1. These fundeps will never serve a purpose in accepting more+ programs: Given constraints do not contain metavariables that could+ be unified via exploring fundeps. They *could* be useful in+ discovering inaccessible code. However, the constraints will be+ Wanteds, and as such will cause errors (not just warnings) if they+ go unsolved. Maybe there is a clever way to get the right+ inaccessible code warnings, but the path forward is far from+ clear. #12466 has further commentary.++2. Furthermore, here is a case where a Given/instance interaction is actively+ harmful (from dependent/should_compile/RaeJobTalk):++ type family a == b :: Bool+ type family Not a = r | r -> a where+ Not False = True+ Not True = False++ [G] Not (a == b) ~ True++ Reacting this Given with the equations for Not produces++ [W] a == b ~ False++ This is indeed a true consequence, and would make sense as a fresh Given.+ But we don't have a way to produce evidence for fundeps, as a Wanted it+ is /harmful/: we can't prove it, and so we'll report an error and reject+ the program. (Previously fundeps gave rise to Deriveds, which+ carried no evidence, so it didn't matter that they could not be proved.)++3. #20922 showed a subtle different problem with Given/instance fundeps.+ type family ZipCons (as :: [k]) (bssx :: [[k]]) = (r :: [[k]]) | r -> as bssx where+ ZipCons (a ': as) (bs ': bss) = (a ': bs) ': ZipCons as bss+ ...++ tclevel = 4+ [G] ZipCons is1 iss ~ (i : is2) : jss++ (The tclevel=4 means that this Given is at level 4.) The fundep tells us that+ 'iss' must be of form (is2 : beta[4]) where beta[4] is a fresh unification+ variable; we don't know what type it stands for. So we would emit+ [W] iss ~ is2 : beta++ Again we can't prove that equality; and worse we'll rewrite iss to+ (is2:beta) in deeply nested contraints inside this implication,+ where beta is untouchable (under other equality constraints), leading+ to other insoluble constraints.++The bottom line: since we have no evidence for them, we should ignore Given/Given+and Given/instance fundeps entirely. -} interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct)@@ -1020,7 +1012,6 @@ what_next <- solveOneFromTheOther ev_i ev_w ; traceTcS "lookupInertDict" (ppr what_next) ; case what_next of- KeepBoth -> continueWith workItem KeepInert -> do { setEvBindIfWanted ev_w (ctEvTerm ev_i) ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) } KeepWork -> do { setEvBindIfWanted ev_i (ctEvTerm ev_w)@@ -1109,7 +1100,7 @@ ; lift $ checkReductionDepth loc' pred - ; evc_vs <- mapM (new_wanted_cached loc' solved_dicts') preds+ ; evc_vs <- mapM (new_wanted_cached ev loc' solved_dicts') preds -- Emit work for subgoals but use our local cache -- so we can solve recursive dictionaries. @@ -1128,50 +1119,45 @@ -- Use a local cache of solved dicts while emitting EvVars for new work -- We bail out of the entire computation if we need to emit an EvVar for -- a subgoal that isn't a ClassPred.- new_wanted_cached :: CtLoc -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew- new_wanted_cached loc cache pty+ new_wanted_cached :: CtEvidence -> CtLoc+ -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew+ new_wanted_cached ev_w loc cache pty | ClassPred cls tys <- classifyPredType pty = lift $ case findDict cache loc_w cls tys of Just ctev -> return $ Cached (ctEvExpr ctev)- Nothing -> Fresh <$> newWantedNC loc pty+ Nothing -> Fresh <$> newWantedNC loc (ctEvRewriters ev_w) pty | otherwise = mzero addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS ()--- Add derived constraints from type-class functional dependencies.+-- Add wanted constraints from type-class functional dependencies. addFunDepWork inerts work_ev cls- | isImprovable work_ev = mapBagM_ add_fds (findDictsByClass (inert_dicts inerts) cls) -- No need to check flavour; fundeps work between -- any pair of constraints, regardless of flavour -- Importantly we don't throw workitem back in the -- worklist because this can cause loops (see #5236)- | otherwise- = return () where work_pred = ctEvPred work_ev work_loc = ctEvLoc work_ev add_fds inert_ct- | isImprovable inert_ev = do { traceTcS "addFunDepWork" (vcat [ ppr work_ev , pprCtLoc work_loc, ppr (isGivenLoc work_loc) , pprCtLoc inert_loc, ppr (isGivenLoc inert_loc)- , pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ]) ;+ , pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ]) - emitFunDepDeriveds $- improveFromAnother derived_loc inert_pred work_pred+ ; unless (isGiven work_ev && isGiven inert_ev) $+ emitFunDepWanteds (ctEvRewriters work_ev) $+ improveFromAnother (derived_loc, inert_rewriters) inert_pred work_pred -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok- -- NB: We do create FDs for given to report insoluble equations that arise- -- from pairs of Givens, and also because of floating when we approximate- -- implications. The relevant test is: typecheck/should_fail/FDsFromGivens.hs+ -- Do not create FDs from Given/Given interactions: See Note [No Given/Given fundeps] }- | otherwise- = return () where inert_ev = ctEvidence inert_ct inert_pred = ctEvPred inert_ev inert_loc = ctEvLoc inert_ev+ inert_rewriters = ctRewriters inert_ct derived_loc = work_loc { ctl_depth = ctl_depth work_loc `maxSubGoalDepth` ctl_depth inert_loc , ctl_origin = FunDepOrigin1 work_pred@@ -1281,24 +1267,22 @@ improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcType -> TcS ()--- Generate derived improvement equalities, by comparing+-- Generate improvement equalities, by comparing -- the current work item with inert CFunEqs--- E.g. x + y ~ z, x + y' ~ z => [D] y ~ y'+-- E.g. x + y ~ z, x + y' ~ z => [W] y ~ y' -- -- See Note [FunDep and implicit parameter reactions]--- Precondition: isImprovable work_ev improveLocalFunEqs work_ev inerts fam_tc args rhs- = assert (isImprovable work_ev) $- unless (null improvement_eqns) $+ = unless (null improvement_eqns) $ do { traceTcS "interactFunEq improvements: " $ vcat [ text "Eqns:" <+> ppr improvement_eqns , text "Candidates:" <+> ppr funeqs_for_tc , text "Inert eqs:" <+> ppr (inert_eqs inerts) ]- ; emitFunDepDeriveds improvement_eqns }+ ; emitFunDepWanteds (ctEvRewriters work_ev) improvement_eqns } where funeqs = inert_funeqs inerts- funeqs_for_tc = [ funeq_ct | EqualCtList (funeq_ct :| _)- <- findFunEqsByTyCon funeqs fam_tc+ funeqs_for_tc = [ funeq_ct | equal_ct_list <- findFunEqsByTyCon funeqs fam_tc+ , funeq_ct <- equal_ct_list , NomEq == ctEqRel funeq_ct ] -- representational equalities don't interact -- with type family dependencies@@ -1307,7 +1291,7 @@ fam_inj_info = tyConInjectivityInfo fam_tc --------------------- improvement_eqns :: [FunDepEqn CtLoc]+ improvement_eqns :: [FunDepEqn (CtLoc, RewriterSet)] improvement_eqns | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc = -- Try built-in families, notably for arithmethic@@ -1322,15 +1306,19 @@ -------------------- do_one_built_in ops rhs (CEqCan { cc_lhs = TyFamLHS _ iargs, cc_rhs = irhs, cc_ev = inert_ev })+ | not (isGiven inert_ev && isGiven work_ev) -- See Note [No Given/Given fundeps] = mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs irhs) + | otherwise+ = []+ do_one_built_in _ _ _ = pprPanic "interactFunEq 1" (ppr fam_tc) -------------------- -- See Note [Type inference for type families with injectivity] do_one_injective inj_args rhs (CEqCan { cc_lhs = TyFamLHS _ inert_args , cc_rhs = irhs, cc_ev = inert_ev })- | isImprovable inert_ev+ | not (isGiven inert_ev && isGiven work_ev) -- See Note [No Given/Given fundeps] , rhs `tcEqType` irhs = mk_fd_eqns inert_ev $ [ Pair arg iarg | (arg, iarg, True) <- zip3 args inert_args inj_args ]@@ -1340,17 +1328,25 @@ do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc) --------------------- mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn CtLoc]+ mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn (CtLoc, RewriterSet)] mk_fd_eqns inert_ev eqns | null eqns = [] | otherwise = [ FDEqn { fd_qtvs = [], fd_eqs = eqns , fd_pred1 = work_pred- , fd_pred2 = ctEvPred inert_ev- , fd_loc = loc } ]+ , fd_pred2 = inert_pred+ , fd_loc = (loc, inert_rewriters) } ] where- inert_loc = ctEvLoc inert_ev- loc = inert_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth`- ctl_depth work_loc }+ initial_loc -- start with the location of the Wanted involved+ | isGiven work_ev = inert_loc+ | otherwise = work_loc+ eqn_orig = InjTFOrigin1 work_pred (ctLocOrigin work_loc) (ctLocSpan work_loc)+ inert_pred (ctLocOrigin inert_loc) (ctLocSpan inert_loc)+ eqn_loc = setCtLocOrigin initial_loc eqn_orig+ inert_pred = ctEvPred inert_ev+ inert_loc = ctEvLoc inert_ev+ inert_rewriters = ctEvRewriters inert_ev+ loc = eqn_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth`+ ctl_depth work_loc } {- Note [Type inference for type families with injectivity] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1358,9 +1354,9 @@ type family F a b = r | r -> b Then if we have an equality like F s1 t1 ~ F s2 t2,-we can use the injectivity to get a new Derived constraint on+we can use the injectivity to get a new Wanted constraint on the injective argument- [D] t1 ~ t2+ [W] t1 ~ t2 That in turn can help GHC solve constraints that would otherwise require guessing. For example, consider the ambiguity check for@@ -1380,15 +1376,15 @@ additional apartness check for the selected equation to check that the selected is guaranteed to fire for given LHS arguments. -These new constraints are simply *Derived* constraints; they have no evidence.+These new constraints are Wanted constraints, but we will not use the evidence. We could go further and offer evidence from decomposing injective type-function applications, but that would require new evidence forms, and an extension to FC, so we don't do that right now (Dec 14). -We generate these Deriveds in three places, depending on how we notice the+We generate these Wanteds in three places, depending on how we notice the injectivity. -1. When we have a [W/D] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and+1. When we have a [W] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and described in Note [Decomposing equality] in GHC.Tc.Solver.Canonical. 2. When we have [W] F tys1 ~ T and [W] F tys2 ~ T. Note that neither of these@@ -1455,10 +1451,7 @@ * We can only do g2 := g1 if g1 can discharge g2; that depends on (a) the role and (b) the flavour. E.g. a representational equality cannot discharge a nominal one; a Wanted cannot discharge a Given.- The predicate is eqCanDischargeFR.--* If the inert is [W] and the work-item is [WD] we don't want to- forget the [D] part; hence the Bool result of inertsCanDischarge.+ The predicate is eqCanRewriteFR. * Visibility. Suppose S :: forall k. k -> Type, and consider unifying S @Type (a::Type) ~ S @(Type->Type) (b::Type->Type)@@ -1479,9 +1472,7 @@ inertsCanDischarge :: InertCans -> Ct -> Maybe ( CtEvidence -- The evidence for the inert- , SwapFlag -- Whether we need mkSymCo- , Bool) -- True <=> keep a [D] version- -- of the [WD] constraint+ , SwapFlag ) -- Whether we need mkSymCo inertsCanDischarge inerts (CEqCan { cc_lhs = lhs_w, cc_rhs = rhs_w , cc_ev = ev_w, cc_eq_rel = eq_rel }) | (ev_i : _) <- [ ev_i | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i@@ -1491,7 +1482,7 @@ , inert_beats_wanted ev_i eq_rel ] = -- Inert: a ~ ty -- Work item: a ~ ty- Just (ev_i, NotSwapped, keep_deriv ev_i)+ Just (ev_i, NotSwapped) | Just rhs_lhs <- canEqLHS_maybe rhs_w , (ev_i : _) <- [ ev_i | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i@@ -1501,7 +1492,7 @@ , inert_beats_wanted ev_i eq_rel ] = -- Inert: a ~ b -- Work item: b ~ a- Just (ev_i, IsSwapped, keep_deriv ev_i)+ Just (ev_i, IsSwapped) where loc_w = ctEvLoc ev_w@@ -1509,22 +1500,14 @@ fr_w = (flav_w, eq_rel) inert_beats_wanted ev_i eq_rel- = -- eqCanDischargeFR: see second bullet of Note [Combining equalities]+ = -- eqCanRewriteFR: see second bullet of Note [Combining equalities] -- strictly_more_visible: see last bullet of Note [Combining equalities]- fr_i`eqCanDischargeFR` fr_w+ fr_i `eqCanRewriteFR` fr_w && not ((loc_w `strictly_more_visible` ctEvLoc ev_i)- && (fr_w `eqCanDischargeFR` fr_i))+ && (fr_w `eqCanRewriteFR` fr_i)) where fr_i = (ctEvFlavour ev_i, eq_rel) - -- See Note [Combining equalities], third bullet- keep_deriv ev_i- | Wanted WOnly <- ctEvFlavour ev_i -- inert is [W]- , Wanted WDeriv <- flav_w -- work item is [WD]- = True -- Keep a derived version of the work item- | otherwise- = False -- Work item is fully discharged- -- See Note [Combining equalities], final bullet strictly_more_visible loc1 loc2 = not (isVisibleOrigin (ctLocOrigin loc2)) &&@@ -1538,20 +1521,13 @@ , cc_rhs = rhs , cc_ev = ev , cc_eq_rel = eq_rel })- | Just (ev_i, swapped, keep_deriv) <- inertsCanDischarge inerts workItem+ | Just (ev_i, swapped) <- inertsCanDischarge inerts workItem = do { setEvBindIfWanted ev $ evCoercion (maybeTcSymCo swapped $ tcDowngradeRole (eqRelRole eq_rel) (ctEvRole ev_i) (ctEvCoercion ev_i)) - ; let deriv_ev = CtDerived { ctev_pred = ctEvPred ev- , ctev_loc = ctEvLoc ev }- ; when keep_deriv $- emitWork [workItem { cc_ev = deriv_ev }]- -- As a Derived it might not be fully rewritten,- -- so we emit it as new work- ; stopWith ev "Solved from inert" } | ReprEq <- eq_rel -- See Note [Do not unify representational equalities]@@ -1562,9 +1538,7 @@ = case lhs of TyVarLHS tv -> tryToSolveByUnification workItem ev tv rhs - TyFamLHS tc args -> do { when (isImprovable ev) $- -- Try improvement, if possible- improveLocalFunEqs ev inerts tc args rhs+ TyFamLHS tc args -> do { improveLocalFunEqs ev inerts tc args rhs ; continueWith workItem } interactEq _ wi = pprPanic "interactEq" (ppr wi)@@ -1597,7 +1571,7 @@ solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS (StopOrContinue Ct) -- Solve with the identity coercion -- Precondition: kind(xi) equals kind(tv)--- Precondition: CtEvidence is Wanted or Derived+-- Precondition: CtEvidence is Wanted -- Precondition: CtEvidence is nominal -- Returns: workItem where -- workItem = the new Given constraint@@ -1632,8 +1606,8 @@ At the end we spontaneously solve that guy, *reunifying* [alpha := Int] We avoid this problem by orienting the resulting given so that the unification-variable is on the left. [Note that alternatively we could attempt to-enforce this at canonicalization]+variable is on the left (note that alternatively we could attempt to+enforce this at canonicalization). See also Note [No touchables as FunEq RHS] in GHC.Tc.Solver.Monad; avoiding double unifications is the main reason we disallow touchable@@ -1710,7 +1684,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Currently, our story of interacting two dictionaries (or a dictionary and top-level instances) for functional dependencies, and implicit-parameters, is that we simply produce new Derived equalities. So for example+parameters, is that we simply produce new Wanted equalities. So for example class D a b | a -> b where ... Inert:@@ -1719,7 +1693,7 @@ d2 :w D Int alpha We generate the extra work item- cv :d alpha ~ Bool+ cv :w alpha ~ Bool where 'cv' is currently unused. However, this new item can perhaps be spontaneously solved to become given and react with d2, discharging it in favour of a new constraint d2' thus:@@ -1728,10 +1702,9 @@ Now d2' can be discharged from d1 We could be more aggressive and try to *immediately* solve the dictionary-using those extra equalities, but that requires those equalities to carry-evidence and derived do not carry evidence.+using those extra equalities. -If that were the case with the same inert set and work item we might dischard+If that were the case with the same inert set and work item we might discard d2 directly: cv :w alpha ~ Bool@@ -1756,10 +1729,10 @@ Note [Fundeps with instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ doTopFundepImprovement compares the constraint with all the instance-declarations, to see if we can produce any derived equalities. E.g+declarations, to see if we can produce any equalities. E.g class C2 a b | a -> b instance C Int Bool-Then the constraint (C Int ty) generates the Derived equality [D] ty ~ Bool.+Then the constraint (C Int ty) generates the equality [W] ty ~ Bool. There is a nasty corner in #19415 which led to the typechecker looping: class C s t b | s -> t@@ -1769,9 +1742,9 @@ work_item: dwrk :: C (T @ka (a::ka)) (T @kb0 (b0::kb0)) Char where kb0, b0 are unification vars ==> {fundeps against instance; k0, y0 fresh unification vars}- [D] T kb0 (b0::kb0) ~ T k0 (y0::k0)+ [W] T kb0 (b0::kb0) ~ T k0 (y0::k0) Add dwrk to inert set- ==> {solve that Derived kb0 := k0, b0 := y0+ ==> {solve that equality kb0 := k0, b0 := y0 Now kick out dwrk, since it mentions kb0 But now we are back to the start! Loop! @@ -1791,7 +1764,7 @@ a) The class has fundeps b) We have not had a successful hit against instances yet -* In doTopFundepImprovement, if we emit some Deriveds we flip the flag+* In doTopFundepImprovement, if we emit some constraints we flip the flag to False, so that we won't try again with the same CDictCan. In our example, dwrk will have its flag set to False. @@ -1828,8 +1801,8 @@ although it's pretty strange. So they are both accepted. Now try [W] GHet (K Int) (K Bool) This triggers fundeps from both instance decls;- [D] K Bool ~ K [a]- [D] K Bool ~ K beta+ [W] K Bool ~ K [a]+ [W] K Bool ~ K beta And there's a risk of complaining about Bool ~ [a]. But in fact the Wanted matches the second instance, so we never get as far as the fundeps.@@ -1837,7 +1810,7 @@ #7875 is a case in point. -} -doTopFundepImprovement ::Ct -> TcS (StopOrContinue Ct)+doTopFundepImprovement :: Ct -> TcS (StopOrContinue Ct) -- Try to functional-dependency improvement betweeen the constraint -- and the top-level instance declarations -- See Note [Fundeps with instances]@@ -1845,13 +1818,13 @@ doTopFundepImprovement work_item@(CDictCan { cc_ev = ev, cc_class = cls , cc_tyargs = xis , cc_fundeps = has_fds })- | has_fds, isImprovable ev+ | has_fds = do { traceTcS "try_fundeps" (ppr work_item) ; instEnvs <- getInstEnvs ; let fundep_eqns = improveFromInstEnv instEnvs mk_ct_loc cls xis ; case fundep_eqns of [] -> continueWith work_item -- No improvement- _ -> do { emitFunDepDeriveds fundep_eqns+ _ -> do { emitFunDepWanteds (ctEvRewriters ev) fundep_eqns ; continueWith (work_item { cc_fundeps = False }) } } | otherwise = continueWith work_item@@ -1863,30 +1836,38 @@ mk_ct_loc :: PredType -- From instance decl -> SrcSpan -- also from instance deol- -> CtLoc+ -> (CtLoc, RewriterSet) mk_ct_loc inst_pred inst_loc- = dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin- inst_pred inst_loc }+ = ( dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin+ inst_pred inst_loc }+ , emptyRewriterSet ) doTopFundepImprovement work_item = pprPanic "doTopFundepImprovement" (ppr work_item) -emitFunDepDeriveds :: [FunDepEqn CtLoc] -> TcS ()+emitFunDepWanteds :: RewriterSet -- from the work item+ -> [FunDepEqn (CtLoc, RewriterSet)] -> TcS () -- See Note [FunDep and implicit parameter reactions]-emitFunDepDeriveds fd_eqns+emitFunDepWanteds work_rewriters fd_eqns = mapM_ do_one_FDEqn fd_eqns where- do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = loc })+ do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = (loc, rewriters) }) | null tvs -- Common shortcut- = do { traceTcS "emitFunDepDeriveds 1" (ppr (ctl_depth loc) $$ ppr eqs $$ ppr (isGivenLoc loc))- ; mapM_ (unifyDerived loc Nominal) eqs }+ = do { traceTcS "emitFunDepWanteds 1" (ppr (ctl_depth loc) $$ ppr eqs $$ ppr (isGivenLoc loc))+ ; mapM_ (\(Pair ty1 ty2) -> unifyWanted all_rewriters loc Nominal ty1 ty2)+ (reverse eqs) }+ -- See Note [Reverse order of fundep equations]+ | otherwise- = do { traceTcS "emitFunDepDeriveds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs)+ = do { traceTcS "emitFunDepWanteds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs) ; subst <- instFlexi tvs -- Takes account of kind substitution- ; mapM_ (do_one_eq loc subst) eqs }+ ; mapM_ (do_one_eq loc all_rewriters subst) (reverse eqs) }+ -- See Note [Reverse order of fundep equations]+ where+ all_rewriters = work_rewriters S.<> rewriters - do_one_eq loc subst (Pair ty1 ty2)- = unifyDerived loc Nominal $- Pair (Type.substTyUnchecked subst ty1) (Type.substTyUnchecked subst ty2)+ do_one_eq loc rewriters subst (Pair ty1 ty2)+ = unifyWanted rewriters loc Nominal+ (Type.substTyUnchecked subst ty1) (Type.substTyUnchecked subst ty2) {- **********************************************************************@@ -1898,7 +1879,7 @@ topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct) -- The work item does not react with the inert set,--- so try interaction with top-level instances. Note:+-- so try interaction with top-level instances. topReactionsStage work_item = do { traceTcS "doTopReact" (ppr work_item) ; case work_item of@@ -1986,6 +1967,47 @@ * Note [Evidence for quantified constraints] in GHC.Core.Predicate * Note [Equality superclasses in quantified constraints] in GHC.Tc.Solver.Canonical++Note [Reverse order of fundep equations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this scenario (from dependent/should_fail/T13135_simple):++ type Sig :: Type -> Type+ data Sig a = SigFun a (Sig a)++ type SmartFun :: forall (t :: Type). Sig t -> Type+ type family SmartFun sig = r | r -> sig where+ SmartFun @Type (SigFun @Type a sig) = a -> SmartFun @Type sig++ [W] SmartFun @kappa sigma ~ (Int -> Bool)++The injectivity of SmartFun allows us to produce two new equalities:++ [W] w1 :: Type ~ kappa+ [W] w2 :: SigFun @Type Int beta ~ sigma++for some fresh (beta :: SigType). The second Wanted here is actually+heterogeneous: the LHS has type Sig Type while the RHS has type Sig kappa.+Of course, if we solve the first wanted first, the second becomes homogeneous.++When looking for injectivity-inspired equalities, we work left-to-right,+producing the two equalities in the order written above. However, these+equalities are then passed into unifyWanted, which will fail, adding these+to the work list. However, crucially, the work list operates like a *stack*.+So, because we add w1 and then w2, we process w2 first. This is silly: solving+w1 would unlock w2. So we make sure to add equalities to the work+list in left-to-right order, which requires a few key calls to 'reverse'.++This treatment is also used for class-based functional dependencies, although+we do not have a program yet known to exhibit a loop there. It just seems+like the right thing to do.++When this was originally conceived, it was necessary to avoid a loop in T13135.+That loop is now avoided by continuing with the kind equality (not the type+equality) in canEqCanLHSHetero (see Note [Equalities with incompatible kinds]+in GHC.Tc.Solver.Canonical). However, the idea of working left-to-right still+seems worthwhile, and so the calls to 'reverse' remain.+ -} --------------------@@ -1999,7 +2021,7 @@ improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcType -> TcS () -- See Note [FunDep and implicit parameter reactions] improveTopFunEqs ev fam_tc args rhs- | not (isImprovable ev)+ | isGiven ev -- See Note [No Given/Given fundeps] = return () | otherwise@@ -2007,11 +2029,15 @@ ; eqns <- improve_top_fun_eqs fam_envs fam_tc args rhs ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs , ppr eqns ])- ; mapM_ (unifyDerived loc Nominal) eqns }+ ; mapM_ (\(Pair ty1 ty2) -> unifyWanted rewriters loc Nominal ty1 ty2)+ (reverse eqns) }+ -- Missing that `reverse` causes T13135 and T13135_simple to loop.+ -- See Note [Reverse order of fundep equations] where loc = bumpCtLocDepth (ctEvLoc ev) -- ToDo: this location is wrong; it should be FunDepOrigin2 -- See #14778+ rewriters = ctEvRewriters ev improve_top_fun_eqs :: FamInstEnvs -> TyCon -> [TcType] -> TcType@@ -2094,7 +2120,7 @@ Note [Improvement orientation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A very delicate point is the orientation of derived equalities+A very delicate point is the orientation of equalities arising from injectivity improvement (#12522). Suppose we have type family F x = t | t -> x type instance F (a, Int) = (Int, G a)@@ -2103,10 +2129,10 @@ [W] TF (alpha, beta) ~ fuv [W] fuv ~ (Int, <some type>) -The injectivity will give rise to derived constraints+The injectivity will give rise to constraints - [D] gamma1 ~ alpha- [D] Int ~ beta+ [W] gamma1 ~ alpha+ [W] Int ~ beta The fresh unification variable gamma1 comes from the fact that we can only do "partial improvement" here; see Section 5.2 of@@ -2115,7 +2141,7 @@ Now, it's very important to orient the equations this way round, so that the fresh unification variable will be eliminated in favour of alpha. If we instead had- [D] alpha ~ gamma1+ [W] alpha ~ gamma1 then we would unify alpha := gamma1; and kick out the wanted constraint. But when we grough it back in, it'd look like [W] TF (gamma1, beta) ~ fuv@@ -2126,7 +2152,7 @@ actual argument (alpha, beta) partly matches the improvement template. But that's a bit tricky, esp when we remember that the kinds much match too; so it's easier to let the normal machinery-handle it. Instead we are careful to orient the new derived+handle it. Instead we are careful to orient the new equality with the template on the left. Delicate, but it works. -}@@ -2142,13 +2168,14 @@ doTopReactDict inerts work_item@(CDictCan { cc_ev = ev, cc_class = cls , cc_tyargs = xis }) | isGiven ev -- Never use instances for Given constraints- = doTopFundepImprovement work_item+ = continueWith work_item+ -- See Note [No Given/Given fundeps] | Just solved_ev <- lookupSolvedDict inerts dict_loc cls xis -- Cached = do { setEvBindIfWanted ev (ctEvTerm solved_ev) ; stopWith ev "Dict/Top (cached)" } - | otherwise -- Wanted or Derived, but not cached+ | otherwise -- Wanted, but not cached = do { dflags <- getDynFlags ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc ; case lkup_res of@@ -2174,32 +2201,16 @@ , cir_mk_ev = mk_ev }) = do { traceTcS "doTopReact/found instance for" $ ppr ev ; deeper_loc <- checkInstanceOK loc what pred- ; if isDerived ev- then -- Use type-class instances for Deriveds, in the hope- -- of generating some improvements- -- C.f. Example 3 of Note [The improvement story]- -- It's easy because no evidence is involved- do { dflags <- getDynFlags- ; unless (subGoalDepthExceeded dflags (ctLocDepth deeper_loc)) $- emitNewDeriveds deeper_loc theta- -- If we have a runaway Derived, let's not issue a- -- "reduction stack overflow" error, which is not particularly- -- friendly. Instead, just drop the Derived.- ; traceTcS "finish_derived" (ppr (ctl_depth deeper_loc))- ; stopWith ev "Dict/Top (solved derived)" }-- else -- wanted- do { checkReductionDepth deeper_loc pred- ; evb <- getTcEvBindsVar- ; if isCoEvBindsVar evb- then continueWith work_item+ ; checkReductionDepth deeper_loc pred+ ; evb <- getTcEvBindsVar+ ; if isCoEvBindsVar evb+ then continueWith work_item -- See Note [Instances in no-evidence implications]-- else- do { evc_vars <- mapM (newWanted deeper_loc) theta+ else+ do { evc_vars <- mapM (newWanted deeper_loc (ctRewriters work_item)) theta ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars)) ; emitWorkNC (freshGoals evc_vars)- ; stopWith ev "Dict/Top (solved wanted)" }}}+ ; stopWith ev "Dict/Top (solved wanted)" }} where ev = ctEvidence work_item pred = ctEvPred ev@@ -2212,8 +2223,7 @@ -- Check that it's OK to use this insstance: -- (a) the use is well staged in the Template Haskell sense -- Returns the CtLoc to used for sub-goals--- Probably also want to call checkReductionDepth, but this function--- does not do so to enable special handling for Deriveds in chooseInstance+-- Probably also want to call checkReductionDepth checkInstanceOK loc what pred = do { checkWellStagedDFun loc what pred ; return deeper_loc }
compiler/GHC/Tc/Solver/Monad.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}@@ -13,8 +14,9 @@ module GHC.Tc.Solver.Monad ( -- The TcS monad- TcS, runTcS, runTcSDeriveds, runTcSDerivedsEarlyAbort, runTcSWithEvBinds,- runTcSInerts, failTcS, warnTcS, addErrTcS, wrapTcS, runTcSEqualities,+ TcS, runTcS, runTcSEarlyAbort, runTcSWithEvBinds, runTcSInerts,+ failTcS, warnTcS, addErrTcS, wrapTcS,+ runTcSEqualities, nestTcS, nestImplicTcS, setEvBindsTcS, emitImplicationTcS, emitTvImplicationTcS, @@ -38,16 +40,14 @@ MaybeNew(..), freshGoals, isFresh, getEvExpr, newTcEvBinds, newNoTcEvBinds,- newWantedEq, newWantedEq_SI, emitNewWantedEq,- newWanted, newWanted_SI, newWantedEvVar,+ newWantedEq, emitNewWantedEq,+ newWanted, newWantedNC, newWantedEvVarNC,- newDerivedNC, newBoundEvVarId, unifyTyVar, reportUnifications, touchabilityTest, TouchabilityTestResult(..), setEvBind, setWantedEq, setWantedEvTerm, setEvBindIfWanted, newEvVar, newGivenEvVar, newGivenEvVars,- emitNewDeriveds, emitNewDerivedEq, checkReductionDepth, getSolvedDicts, setSolvedDicts, @@ -67,7 +67,6 @@ removeInertCts, getPendingGivenScs, addInertCan, insertFunEq, addInertForAll, emitWorkNC, emitWork,- isImprovable, lookupInertDict, -- The Model@@ -130,7 +129,8 @@ import qualified GHC.Tc.Utils.TcMType as TcM import qualified GHC.Tc.Instance.Class as TcM( matchGlobalInst, ClsInstResult(..) ) import qualified GHC.Tc.Utils.Env as TcM- ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl )+ ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl+ , tcInitTidyEnv ) import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap, instanceReturnsDictCon ) import GHC.Tc.Utils.TcType import GHC.Driver.Session@@ -145,8 +145,8 @@ import GHC.Tc.Types.Evidence import GHC.Core.Class import GHC.Core.TyCon-import GHC.Tc.Errors ( solverDepthErrorTcS ) import GHC.Tc.Errors.Types+import GHC.Types.Error ( mkPlainError, noHints ) import GHC.Types.Name import GHC.Types.TyThing@@ -167,15 +167,14 @@ import GHC.Tc.Types.Constraint import GHC.Tc.Utils.Unify import GHC.Core.Predicate--import GHC.Types.Unique.Set+import GHC.Types.Unique.Set (nonDetEltsUniqSet)+import GHC.Utils.Panic.Plain import Control.Monad import GHC.Utils.Monad import Data.IORef import GHC.Exts (oneShot)-import Data.List ( mapAccumL, partition )-import Data.List.NonEmpty ( NonEmpty(..) )+import Data.List ( mapAccumL, partition, find ) #if defined(DEBUG) import GHC.Data.Graph.Directed@@ -183,358 +182,6 @@ {- ********************************************************************* * *- Shadow constraints and improvement-* *-************************************************************************--Note [The improvement story and derived shadows]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Because Wanteds cannot rewrite Wanteds (see Note [Wanteds do not-rewrite Wanteds] in GHC.Tc.Types.Constraint), we may miss some opportunities for-solving. Here's a classic example (indexed-types/should_fail/T4093a)-- Ambiguity check for f: (Foo e ~ Maybe e) => Foo e-- We get [G] Foo e ~ Maybe e (CEqCan)- [W] Foo ee ~ Foo e (CEqCan) -- ee is a unification variable- [W] Foo ee ~ Maybe ee (CEqCan)-- The first Wanted gets rewritten to-- [W] Foo ee ~ Maybe e-- But now we appear to be stuck, since we don't rewrite Wanteds with- Wanteds. This is silly because we can see that ee := e is the- only solution.--The basic plan is- * generate Derived constraints that shadow Wanted constraints- * allow Derived to rewrite Derived- * in order to cause some unifications to take place- * that in turn solve the original Wanteds--The ONLY reason for all these Derived equalities is to tell us how to-unify a variable: that is, what Mark Jones calls "improvement".--The same idea is sometimes also called "saturation"; find all the-equalities that must hold in any solution.--Or, equivalently, you can think of the derived shadows as implementing-the "model": a non-idempotent but no-occurs-check substitution,-reflecting *all* *Nominal* equalities (a ~N ty) that are not-immediately soluble by unification.--More specifically, here's how it works (Oct 16):--* Wanted constraints are born as [WD]; this behaves like a- [W] and a [D] paired together.--* When we are about to add a [WD] to the inert set, if it can- be rewritten by a [D] a ~ ty, then we split it into [W] and [D],- putting the latter into the work list (see maybeEmitShadow).--In the example above, we get to the point where we are stuck:- [WD] Foo ee ~ Foo e- [WD] Foo ee ~ Maybe ee--But now when [WD] Foo ee ~ Maybe ee is about to be added, we'll-split it into [W] and [D], since the inert [WD] Foo ee ~ Foo e-can rewrite it. Then:- work item: [D] Foo ee ~ Maybe ee- inert: [W] Foo ee ~ Maybe ee- [WD] Foo ee ~ Maybe e--See Note [Splitting WD constraints]. Now the work item is rewritten-by the [WD] and we soon get ee := e.--Additional notes:-- * The derived shadow equalities live in inert_eqs, along with- the Givens and Wanteds; see Note [EqualCtList invariants]- in GHC.Tc.Solver.Types.-- * We make Derived shadows only for Wanteds, not Givens. So we- have only [G], not [GD] and [G] plus splitting. See- Note [Add derived shadows only for Wanteds]-- * We also get Derived equalities from functional dependencies- and type-function injectivity; see calls to unifyDerived.-- * It's worth having [WD] rather than just [W] and [D] because- * efficiency: silly to process the same thing twice- * inert_dicts is a finite map keyed by- the type; it's inconvenient for it to map to TWO constraints--Another example requiring Deriveds is in-Note [Put touchable variables on the left] in GHC.Tc.Solver.Canonical.--Note [Splitting WD constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We are about to add a [WD] constraint to the inert set; and we-know that the inert set has fully rewritten it. Should we split-it into [W] and [D], and put the [D] in the work list for further-work?--* CDictCan (C tys):- Yes if the inert set could rewrite tys to make the class constraint,- or type family, fire. That is, yes if the inert_eqs intersects- with the free vars of tys. For this test we use- (anyRewritableTyVar True) which ignores casts and coercions in tys,- because rewriting the casts or coercions won't make the thing fire- more often.--* CEqCan (lhs ~ ty): Yes if the inert set could rewrite 'lhs' or 'ty'.- We need to check both 'lhs' and 'ty' against the inert set:- - Inert set contains [D] a ~ ty2- Then we want to put [D] a ~ ty in the worklist, so we'll- get [D] ty ~ ty2 with consequent good things-- - Inert set contains [D] b ~ a, where b is in ty.- We can't just add [WD] a ~ ty[b] to the inert set, because- that breaks the inert-set invariants. If we tried to- canonicalise another [D] constraint mentioning 'a', we'd- get an infinite loop-- Moreover we must use (anyRewritableTyVar False) for the RHS,- because even tyvars in the casts and coercions could give- an infinite loop if we don't expose it--* CIrredCan: Yes if the inert set can rewrite the constraint.- We used to think splitting irreds was unnecessary, but- see Note [Splitting Irred WD constraints]--* Others: nothing is gained by splitting.--Note [Splitting Irred WD constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Splitting Irred constraints can make a difference. Here is the-scenario:-- a[sk] :: F v -- F is a type family- beta :: alpha-- work item: [WD] a ~ beta--This is heterogeneous, so we emit a kind equality and make the work item an-inert Irred.-- work item: [D] F v ~ alpha- inert: [WD] (a |> co) ~ beta (CIrredCan)--Can't make progress on the work item. Add to inert set. This kicks out the-old inert, because a [D] can rewrite a [WD].-- work item: [WD] (a |> co) ~ beta- inert: [D] F v ~ alpha (CEqCan)--Can't make progress on this work item either (although GHC tries by-decomposing the cast and rewriting... but that doesn't make a difference),-which is still hetero. Emit a new kind equality and add to inert set. But,-critically, we split the Irred.-- work list:- [D] F v ~ alpha (CEqCan)- [D] (a |> co) ~ beta (CIrred) -- this one was split off- inert:- [W] (a |> co) ~ beta- [D] F v ~ alpha--We quickly solve the first work item, as it's the same as an inert.-- work item: [D] (a |> co) ~ beta- inert:- [W] (a |> co) ~ beta- [D] F v ~ alpha--We decompose the cast, yielding-- [D] a ~ beta--We then rewrite the kinds. The lhs kind is F v, which flattens to alpha.-- co' :: F v ~ alpha- [D] (a |> co') ~ beta--Now this equality is homo-kinded. So we swizzle it around to-- [D] beta ~ (a |> co')--and set beta := a |> co', and go home happy.--If we don't split the Irreds, we loop. This is all dangerously subtle.--This is triggered by test case typecheck/should_compile/SplitWD.--Note [Add derived shadows only for Wanteds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We only add shadows for Wanted constraints. That is, we have-[WD] but not [GD]; and maybeEmitShaodw looks only at [WD]-constraints.--It does just possibly make sense ot add a derived shadow for a-Given. If we created a Derived shadow of a Given, it could be-rewritten by other Deriveds, and that could, conceivably, lead to a-useful unification.--But (a) I have been unable to come up with an example of this- happening- (b) see #12660 for how adding the derived shadows- of a Given led to an infinite loop.- (c) It's unlikely that rewriting derived Givens will lead- to a unification because Givens don't mention touchable- unification variables--For (b) there may be other ways to solve the loop, but simply-reraining from adding derived shadows of Givens is particularly-simple. And it's more efficient too!--Still, here's one possible reason for adding derived shadows-for Givens. Consider- work-item [G] a ~ [b], inerts has [D] b ~ a.-If we added the derived shadow (into the work list)- [D] a ~ [b]-When we process it, we'll rewrite to a ~ [a] and get an-occurs check. Without it we'll miss the occurs check (reporting-inaccessible code); but that's probably OK.--Note [Keep CDictCan shadows as CDictCan]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have- class C a => D a b-and [G] D a b, [G] C a in the inert set. Now we insert-[D] b ~ c. We want to kick out a derived shadow for [D] D a b,-so we can rewrite it with the new constraint, and perhaps get-instance reduction or other consequences.--BUT we do not want to kick out a *non-canonical* (D a b). If we-did, we would do this:- - rewrite it to [D] D a c, with pend_sc = True- - use expandSuperClasses to add C a- - go round again, which solves C a from the givens-This loop goes on for ever and triggers the simpl_loop limit.--Solution: kick out the CDictCan which will have pend_sc = False,-because we've already added its superclasses. So we won't re-add-them. If we forget the pend_sc flag, our cunning scheme for avoiding-generating superclasses repeatedly will fail.--See #11379 for a case of this.--Note [Do not do improvement for WOnly]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We do improvement between two constraints (e.g. for injectivity-or functional dependencies) only if both are "improvable". And-we improve a constraint wrt the top-level instances only if-it is improvable.--Improvable: [G] [WD] [D}-Not improvable: [W]--Reasons:--* It's less work: fewer pairs to compare--* Every [W] has a shadow [D] so nothing is lost--* Consider [WD] C Int b, where 'b' is a skolem, and- class C a b | a -> b- instance C Int Bool- We'll do a fundep on it and emit [D] b ~ Bool- That will kick out constraint [WD] C Int b- Then we'll split it to [W] C Int b (keep in inert)- and [D] C Int b (in work list)- When processing the latter we'll rewrite it to- [D] C Int Bool- At that point it would be /stupid/ to interact it- with the inert [W] C Int b in the inert set; after all,- it's the very constraint from which the [D] C Int Bool- was split! We can avoid this by not doing improvement- on [W] constraints. This came up in #12860.--}--maybeEmitShadow :: InertCans -> Ct -> TcS Ct--- See Note [The improvement story and derived shadows]-maybeEmitShadow ics ct- | let ev = ctEvidence ct- , CtWanted { ctev_pred = pred, ctev_loc = loc- , ctev_nosh = WDeriv } <- ev- , shouldSplitWD (inert_eqs ics) (inert_funeqs ics) ct- = do { traceTcS "Emit derived shadow" (ppr ct)- ; let derived_ev = CtDerived { ctev_pred = pred- , ctev_loc = loc }- shadow_ct = ct { cc_ev = derived_ev }- -- Te shadow constraint keeps the canonical shape.- -- This just saves work, but is sometimes important;- -- see Note [Keep CDictCan shadows as CDictCan]- ; emitWork [shadow_ct]-- ; let ev' = ev { ctev_nosh = WOnly }- ct' = ct { cc_ev = ev' }- -- Record that it now has a shadow- -- This is /the/ place we set the flag to WOnly- ; return ct' }-- | otherwise- = return ct--shouldSplitWD :: InertEqs -> FunEqMap EqualCtList -> Ct -> Bool--- Precondition: 'ct' is [WD], and is inert--- True <=> we should split ct ito [W] and [D] because--- the inert_eqs can make progress on the [D]--- See Note [Splitting WD constraints]--shouldSplitWD inert_eqs fun_eqs (CDictCan { cc_tyargs = tys })- = should_split_match_args inert_eqs fun_eqs tys- -- NB True: ignore coercions- -- See Note [Splitting WD constraints]--shouldSplitWD inert_eqs fun_eqs (CEqCan { cc_lhs = TyVarLHS tv, cc_rhs = ty- , cc_eq_rel = eq_rel })- = tv `elemDVarEnv` inert_eqs- || anyRewritableCanEqLHS eq_rel (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs) ty- -- NB False: do not ignore casts and coercions- -- See Note [Splitting WD constraints]--shouldSplitWD inert_eqs fun_eqs (CEqCan { cc_ev = ev, cc_eq_rel = eq_rel })- = anyRewritableCanEqLHS eq_rel (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs)- (ctEvPred ev)--shouldSplitWD inert_eqs fun_eqs (CIrredCan { cc_ev = ev })- = anyRewritableCanEqLHS (ctEvEqRel ev) (canRewriteTv inert_eqs)- (canRewriteTyFam fun_eqs) (ctEvPred ev)--shouldSplitWD _ _ _ = False -- No point in splitting otherwise--should_split_match_args :: InertEqs -> FunEqMap EqualCtList -> [TcType] -> Bool--- True if the inert_eqs can rewrite anything in the argument types-should_split_match_args inert_eqs fun_eqs tys- = any (anyRewritableCanEqLHS NomEq (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs)) tys- -- See Note [Splitting WD constraints]--canRewriteTv :: InertEqs -> EqRel -> TyVar -> Bool-canRewriteTv inert_eqs eq_rel tv- | Just (EqualCtList (ct :| _)) <- lookupDVarEnv inert_eqs tv- , CEqCan { cc_eq_rel = eq_rel1 } <- ct- = eq_rel1 `eqCanRewrite` eq_rel- | otherwise- = False--canRewriteTyFam :: FunEqMap EqualCtList -> EqRel -> TyCon -> [Type] -> Bool-canRewriteTyFam fun_eqs eq_rel tf args- | Just (EqualCtList (ct :| _)) <- findFunEq fun_eqs tf args- , CEqCan { cc_eq_rel = eq_rel1 } <- ct- = eq_rel1 `eqCanRewrite` eq_rel- | otherwise- = False--isImprovable :: CtEvidence -> Bool--- See Note [Do not do improvement for WOnly]-isImprovable (CtWanted { ctev_nosh = WOnly }) = False-isImprovable _ = True---{- *********************************************************************-* * Inert instances: inert_insts * * ********************************************************************* -}@@ -601,14 +248,28 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When adding an equality to the inerts: -* Split [WD] into [W] and [D] if the inerts can rewrite the latter;- done by maybeEmitShadow.- * Kick out any constraints that can be rewritten by the thing we are adding. Done by kickOutRewritable. * Note that unifying a:=ty, is like adding [G] a~ty; just use kickOutRewritable with Nominal, Given. See kickOutAfterUnification.++Note [Kick out existing binding for implicit parameter]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have (typecheck/should_compile/ImplicitParamFDs)+ flub :: (?x :: Int) => (Int, Integer)+ flub = (?x, let ?x = 5 in ?x)+When we are checking the last ?x occurrence, we guess its type+to be a fresh unification variable alpha and emit an (IP "x" alpha)+constraint. But the given (?x :: Int) has been translated to an+IP "x" Int constraint, which has a functional dependency from the+name to the type. So fundep interaction tells us that alpha ~ Int,+and we get a type error. This is bad.++Instead, we wish to excise any old given for an IP when adding a+new one. We also must make sure not to float out+any IP constraints outside an implication that binds an IP of+the same name; see GHC.Tc.Solver.floatConstraints. -} addInertCan :: Ct -> TcS ()@@ -620,7 +281,6 @@ ; mkTcS (\TcSEnv{tcs_abort_on_insoluble=abort_flag} -> when (abort_flag && insolubleEqCt ct) TcM.failM) ; ics <- getInertCans- ; ct <- maybeEmitShadow ics ct ; ics <- maybeKickOut ics ct ; tclvl <- getTcLevel ; setInertCans (addInertItem tclvl ics ct)@@ -633,6 +293,27 @@ | CEqCan { cc_lhs = lhs, cc_ev = ev, cc_eq_rel = eq_rel } <- ct = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) lhs ics ; return ics' }++ -- See [Kick out existing binding for implicit parameter]+ | isGivenCt ct+ , CDictCan { cc_class = cls, cc_tyargs = [ip_name_strty, _ip_ty] } <- ct+ , isIPClass cls+ , Just ip_name <- isStrLitTy ip_name_strty+ -- Would this be more efficient if we used findDictsByClass and then delDict?+ = let dict_map = inert_dicts ics+ dict_map' = filterDicts doesn't_match_ip_name dict_map++ doesn't_match_ip_name :: Ct -> Bool+ doesn't_match_ip_name ct+ | Just (inert_ip_name, _inert_ip_ty) <- isIPPred_maybe (ctPred ct)+ = inert_ip_name /= ip_name++ | otherwise+ = True++ in+ return (ics { inert_dicts = dict_map' })+ | otherwise = return ics @@ -682,8 +363,10 @@ ; return n_kicked } -- See Wrinkle (2) in Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical-kickOutAfterFillingCoercionHole :: CoercionHole -> Coercion -> TcS ()-kickOutAfterFillingCoercionHole hole filled_co+-- It's possible that this could just go ahead and unify, but could there be occurs-check+-- problems? Seems simpler just to kick out.+kickOutAfterFillingCoercionHole :: CoercionHole -> TcS ()+kickOutAfterFillingCoercionHole hole = do { ics <- getInertCans ; let (kicked_out, ics') = kick_out ics n_kicked = workListSize kicked_out@@ -698,39 +381,25 @@ ; setInertCans ics' } where- holes_of_co = coercionHolesOfCo filled_co- kick_out :: InertCans -> (WorkList, InertCans)- kick_out ics@(IC { inert_blocked = blocked })- = let (to_kick, to_keep) = partitionBagWith kick_ct blocked-- kicked_out = extendWorkListCts (bagToList to_kick) emptyWorkList- ics' = ics { inert_blocked = to_keep }- in- (kicked_out, ics')-- kick_ct :: Ct -> Either Ct Ct- -- Left: kick out; Right: keep. But even if we keep, we may need- -- to update the set of blocking holes- kick_ct ct@(CIrredCan { cc_reason = HoleBlockerReason holes })- | hole `elementOfUniqSet` holes- = let new_holes = holes `delOneFromUniqSet` hole- `unionUniqSets` holes_of_co- updated_ct = ct { cc_reason = HoleBlockerReason new_holes }- in- if isEmptyUniqSet new_holes- then Left updated_ct- else Right updated_ct-- | otherwise- = Right ct+ kick_out ics@(IC { inert_eqs = eqs, inert_funeqs = funeqs })+ = (kicked_out, ics { inert_eqs = eqs_to_keep, inert_funeqs = funeqs_to_keep })+ where+ (eqs_to_kick, eqs_to_keep) = partitionInertEqs kick_ct eqs+ (funeqs_to_kick, funeqs_to_keep) = partitionFunEqs kick_ct funeqs+ kicked_out = extendWorkListCts (eqs_to_kick ++ funeqs_to_kick) emptyWorkList - kick_ct other = pprPanic "kickOutAfterFillingCoercionHole" (ppr other)+ kick_ct :: Ct -> Bool+ -- True: kick out; False: keep.+ kick_ct (CEqCan { cc_rhs = rhs, cc_ev = ctev })+ = isWanted ctev && -- optimisation: givens don't have coercion holes anyway+ rhs `hasThisCoercionHoleTy` hole+ kick_ct other = pprPanic "kick_ct (coercion hole)" (ppr other) -------------- addInertSafehask :: InertCans -> Ct -> InertCans addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })- = ics { inert_safehask = addDictCt (inert_dicts ics) (classTyCon cls) tys item }+ = ics { inert_safehask = addDict (inert_dicts ics) cls tys item } addInertSafehask _ item = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item@@ -816,7 +485,7 @@ updInertIrreds upd_fn = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) } -getInertEqs :: TcS (DTyVarEnv EqualCtList)+getInertEqs :: TcS InertEqs getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) } getInnermostGivenEqLevel :: TcS TcLevel@@ -840,9 +509,8 @@ getInertGivens = do { inerts <- getInertCans ; let all_cts = foldDicts (:) (inert_dicts inerts)- $ foldFunEqs (\ecl out -> equalCtListToList ecl ++ out)- (inert_funeqs inerts)- $ concatMap equalCtListToList (dVarEnvElts (inert_eqs inerts))+ $ foldFunEqs (++) (inert_funeqs inerts)+ $ foldDVarEnv (++) [] (inert_eqs inerts) ; return (filter isGivenCt all_cts) } getPendingGivenScs :: TcS [Ct]@@ -878,7 +546,7 @@ add :: Ct -> DictMap Ct -> DictMap Ct add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts- = addDictCt dicts (classTyCon cls) tys ct+ = addDict dicts cls tys ct add ct _ = pprPanic "getPendingScDicts" (ppr ct) get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)@@ -895,27 +563,24 @@ getUnsolvedInerts :: TcS ( Bag Implication , Cts ) -- All simple constraints--- Return all the unsolved [Wanted] or [Derived] constraints+-- Return all the unsolved [Wanted] constraints -- -- Post-condition: the returned simple constraints are all fully zonked -- (because they come from the inert set) -- the unsolved implics may not be getUnsolvedInerts- = do { IC { inert_eqs = tv_eqs- , inert_funeqs = fun_eqs- , inert_irreds = irreds- , inert_blocked = blocked- , inert_dicts = idicts+ = do { IC { inert_eqs = tv_eqs+ , inert_funeqs = fun_eqs+ , inert_irreds = irreds+ , inert_dicts = idicts } <- getInertCans - ; let unsolved_tv_eqs = foldTyEqs add_if_unsolved tv_eqs emptyCts- unsolved_fun_eqs = foldFunEqs add_if_unsolveds fun_eqs emptyCts- unsolved_irreds = Bag.filterBag is_unsolved irreds- unsolved_blocked = blocked -- all blocked equalities are W/D- unsolved_dicts = foldDicts add_if_unsolved idicts emptyCts- unsolved_others = unionManyBags [ unsolved_irreds- , unsolved_dicts- , unsolved_blocked ]+ ; let unsolved_tv_eqs = foldTyEqs add_if_unsolved tv_eqs emptyCts+ unsolved_fun_eqs = foldFunEqs add_if_unsolveds fun_eqs emptyCts+ unsolved_irreds = Bag.filterBag isWantedCt irreds+ unsolved_dicts = foldDicts add_if_unsolved idicts emptyCts+ unsolved_others = unionManyBags [ unsolved_irreds+ , unsolved_dicts ] ; implics <- getWorkListImplics @@ -930,14 +595,11 @@ unsolved_others) } where add_if_unsolved :: Ct -> Cts -> Cts- add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts- | otherwise = cts+ add_if_unsolved ct cts | isWantedCt ct = ct `consCts` cts+ | otherwise = cts add_if_unsolveds :: EqualCtList -> Cts -> Cts- add_if_unsolveds new_cts old_cts = foldr add_if_unsolved old_cts- (equalCtListToList new_cts)-- is_unsolved ct = not (isGivenCt ct) -- Wanted or Derived+ add_if_unsolveds new_cts old_cts = foldr add_if_unsolved old_cts new_cts getHasGivenEqs :: TcLevel -- TcLevel of this implication -> TcS ( HasGivenEqs -- are there Given equalities?@@ -970,15 +632,8 @@ insoluble_given_equality ct = insolubleEqCt ct && isGivenCt ct -{- Note [Unsolved Derived equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In getUnsolvedInerts, we return a derived equality from the inert_eqs-because it is a candidate for floating out of this implication. We-only float equalities with a meta-tyvar on the left, so we only pull-those out here.--Note [What might equal later?]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [What might equal later?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We must determine whether a Given might later equal a Wanted. We definitely need to account for the possibility that any metavariable might be arbitrarily instantiated. Yet we do *not* want@@ -1084,16 +739,17 @@ pprPanic "removeInertCt" (ppr "CSpecialCan" <+> parens (ppr special_pred)) -- | Looks up a family application in the inerts.-lookupFamAppInert :: TyCon -> [Type] -> TcS (Maybe (Reduction, CtFlavourRole))-lookupFamAppInert fam_tc tys+lookupFamAppInert :: (CtFlavourRole -> Bool) -- can it rewrite the target?+ -> TyCon -> [Type] -> TcS (Maybe (Reduction, CtFlavourRole))+lookupFamAppInert rewrite_pred fam_tc tys = do { IS { inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts ; return (lookup_inerts inert_funeqs) } where lookup_inerts inert_funeqs- | Just (EqualCtList (CEqCan { cc_ev = ctev, cc_rhs = rhs } :| _))- <- findFunEq inert_funeqs fam_tc tys- = Just (mkReduction (ctEvCoercion ctev) rhs- ,ctEvFlavourRole ctev)+ | Just ecl <- findFunEq inert_funeqs fam_tc tys+ , Just (CEqCan { cc_ev = ctev, cc_rhs = rhs })+ <- find (rewrite_pred . ctFlavourRole) ecl+ = Just (mkReduction (ctEvCoercion ctev) rhs, ctEvFlavourRole ctev) | otherwise = Nothing lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence)@@ -1139,7 +795,6 @@ ; when (gopt Opt_FamAppCache dflags) $ do { traceTcS "extendFamAppCache" (vcat [ ppr tc <+> ppr xi_args , ppr ty ])- -- 'co' can be bottom, in the case of derived items ; updInertTcS $ \ is@(IS { inert_famapp_cache = fc }) -> is { inert_famapp_cache = insertFunEq fc tc xi_args stuff } } } @@ -1330,19 +985,11 @@ ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var ; return (res, ev_binds) } --- | This variant of 'runTcS' will keep solving, even when only Deriveds--- are left around. It also doesn't return any evidence, as callers won't--- need it.-runTcSDeriveds :: TcS a -> TcM a-runTcSDeriveds tcs- = do { ev_binds_var <- TcM.newTcEvBinds- ; runTcSWithEvBinds ev_binds_var tcs }----- | This variant of 'runTcSDeriveds' will immediatley fail upon encountering an--- insoluble ct. See Note [Speeding up valid-hole fits]-runTcSDerivedsEarlyAbort :: TcS a -> TcM a-runTcSDerivedsEarlyAbort tcs+-- | This variant of 'runTcS' will immediatley fail upon encountering an+-- insoluble ct. See Note [Speeding up valid hole-fits]. Its one usage+-- site does not need the ev_binds, so we do not return them.+runTcSEarlyAbort :: TcS a -> TcM a+runTcSEarlyAbort tcs = do { ev_binds_var <- TcM.newTcEvBinds ; runTcSWithEvBinds' True True ev_binds_var tcs } @@ -1915,7 +1562,7 @@ * There's a deeply-nested chain of implication constraints. ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int - * From the innermost one we get a [D] alpha[1] ~ Int,+ * From the innermost one we get a [W] alpha[1] ~ Int, so we can unify. * It's better not to iterate the inner implications, but go all the@@ -2082,7 +1729,7 @@ fillCoercionHole :: CoercionHole -> Coercion -> TcS () fillCoercionHole hole co = do { wrapTcS $ TcM.fillCoercionHole hole co- ; kickOutAfterFillingCoercionHole hole co }+ ; kickOutAfterFillingCoercionHole hole } setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS () setEvBindIfWanted ev tm@@ -2119,103 +1766,69 @@ newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence] newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts -emitNewWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS Coercion+emitNewWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS Coercion -- | Emit a new Wanted equality into the work-list-emitNewWantedEq loc role ty1 ty2- = do { (ev, co) <- newWantedEq loc role ty1 ty2+emitNewWantedEq loc rewriters role ty1 ty2+ = do { (ev, co) <- newWantedEq loc rewriters role ty1 ty2 ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) ; return co } -- | Make a new equality CtEvidence-newWantedEq :: CtLoc -> Role -> TcType -> TcType+newWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS (CtEvidence, Coercion)-newWantedEq = newWantedEq_SI WDeriv--newWantedEq_SI :: ShadowInfo -> CtLoc -> Role- -> TcType -> TcType- -> TcS (CtEvidence, Coercion)-newWantedEq_SI si loc role ty1 ty2+newWantedEq loc rewriters role ty1 ty2 = do { hole <- wrapTcS $ TcM.newCoercionHole pty ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty)- ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole- , ctev_nosh = si- , ctev_loc = loc}+ ; return ( CtWanted { ctev_pred = pty+ , ctev_dest = HoleDest hole+ , ctev_loc = loc+ , ctev_rewriters = rewriters } , mkHoleCo hole ) } where pty = mkPrimEqPredRole role ty1 ty2 -- no equalities here. Use newWantedEq instead-newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence-newWantedEvVarNC = newWantedEvVarNC_SI WDeriv--newWantedEvVarNC_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS CtEvidence+newWantedEvVarNC :: CtLoc -> RewriterSet+ -> TcPredType -> TcS CtEvidence -- Don't look up in the solved/inerts; we know it's not there-newWantedEvVarNC_SI si loc pty+newWantedEvVarNC loc rewriters pty = do { new_ev <- newEvVar pty ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$ pprCtLoc loc)- ; return (CtWanted { ctev_pred = pty, ctev_dest = EvVarDest new_ev- , ctev_nosh = si- , ctev_loc = loc })}--newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew-newWantedEvVar = newWantedEvVar_SI WDeriv+ ; return (CtWanted { ctev_pred = pty+ , ctev_dest = EvVarDest new_ev+ , ctev_loc = loc+ , ctev_rewriters = rewriters })} -newWantedEvVar_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS MaybeNew+newWantedEvVar :: CtLoc -> RewriterSet+ -> TcPredType -> TcS MaybeNew -- For anything except ClassPred, this is the same as newWantedEvVarNC-newWantedEvVar_SI si loc pty- = do { mb_ct <- lookupInInerts loc pty+newWantedEvVar loc rewriters pty+ = assert (not (isHoleDestPred pty)) $+ do { mb_ct <- lookupInInerts loc pty ; case mb_ct of Just ctev- | not (isDerived ctev) -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev ; return $ Cached (ctEvExpr ctev) }- _ -> do { ctev <- newWantedEvVarNC_SI si loc pty+ _ -> do { ctev <- newWantedEvVarNC loc rewriters pty ; return (Fresh ctev) } } -newWanted :: CtLoc -> PredType -> TcS MaybeNew+newWanted :: CtLoc -> RewriterSet -> PredType -> TcS MaybeNew -- Deals with both equalities and non equalities. Tries to look -- up non-equalities in the cache-newWanted = newWanted_SI WDeriv--newWanted_SI :: ShadowInfo -> CtLoc -> PredType -> TcS MaybeNew-newWanted_SI si loc pty+newWanted loc rewriters pty | Just (role, ty1, ty2) <- getEqPredTys_maybe pty- = Fresh . fst <$> newWantedEq_SI si loc role ty1 ty2+ = Fresh . fst <$> newWantedEq loc rewriters role ty1 ty2 | otherwise- = newWantedEvVar_SI si loc pty+ = newWantedEvVar loc rewriters pty -- deals with both equalities and non equalities. Doesn't do any cache lookups.-newWantedNC :: CtLoc -> PredType -> TcS CtEvidence-newWantedNC loc pty+newWantedNC :: CtLoc -> RewriterSet -> PredType -> TcS CtEvidence+newWantedNC loc rewriters pty | Just (role, ty1, ty2) <- getEqPredTys_maybe pty- = fst <$> newWantedEq loc role ty1 ty2- | otherwise- = newWantedEvVarNC loc pty--emitNewDeriveds :: CtLoc -> [TcPredType] -> TcS ()-emitNewDeriveds loc preds- | null preds- = return ()+ = fst <$> newWantedEq loc rewriters role ty1 ty2 | otherwise- = do { evs <- mapM (newDerivedNC loc) preds- ; traceTcS "Emitting new deriveds" (ppr evs)- ; updWorkListTcS (extendWorkListDeriveds evs) }--emitNewDerivedEq :: CtLoc -> Role -> TcType -> TcType -> TcS ()--- Create new equality Derived and put it in the work list--- There's no caching, no lookupInInerts-emitNewDerivedEq loc role ty1 ty2- = do { ev <- newDerivedNC loc (mkPrimEqPredRole role ty1 ty2)- ; traceTcS "Emitting new derived equality" (ppr ev $$ pprCtLoc loc)- ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) }- -- Very important: put in the wl_eqs- -- See Note [Prioritise equalities] in GHC.Tc.Solver.InertSet- -- (Avoiding fundep iteration)--newDerivedNC :: CtLoc -> TcPredType -> TcS CtEvidence-newDerivedNC loc pred- = return $ CtDerived { ctev_pred = pred, ctev_loc = loc }+ = newWantedEvVarNC loc rewriters pty -- --------- Check done in GHC.Tc.Solver.Interact.selectNewWorkItem???? --------- -- | Checks if the depth of the given location is too much. Fails if@@ -2225,8 +1838,7 @@ checkReductionDepth loc ty = do { dflags <- getDynFlags ; when (subGoalDepthExceeded dflags (ctLocDepth loc)) $- wrapErrTcS $- solverDepthErrorTcS loc ty }+ wrapErrTcS $ solverDepthError loc ty } matchFam :: TyCon -> [Type] -> TcS (Maybe ReductionN) matchFam tycon args = wrapTcS $ matchFamTcM tycon args@@ -2248,6 +1860,28 @@ 2 (vcat [ text "Rewrites to:" <+> ppr ty , text "Coercion:" <+> ppr co ]) +solverDepthError :: CtLoc -> TcType -> TcM a+solverDepthError loc ty+ = TcM.setCtLocM loc $+ do { ty <- TcM.zonkTcType ty+ ; env0 <- TcM.tcInitTidyEnv+ ; let tidy_env = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty)+ tidy_ty = tidyType tidy_env ty+ msg = TcRnUnknownMessage $ mkPlainError noHints $+ vcat [ text "Reduction stack overflow; size =" <+> ppr depth+ , hang (text "When simplifying the following type:")+ 2 (ppr tidy_ty)+ , note ]+ ; TcM.failWithTcM (tidy_env, msg) }+ where+ depth = ctLocDepth loc+ note = vcat+ [ text "Use -freduction-depth=0 to disable this check"+ , text "(any upper bound you could choose might fail unpredictably with"+ , text " minor updates to GHC, so disabling the check is recommended if"+ , text " you're sure that type checking should terminate)" ]++ {- ************************************************************************ * *@@ -2287,16 +1921,12 @@ flavour = ctEvFlavour ev eq_rel = ctEvEqRel ev - final_check- | Given <- flavour- = return True- | ctFlavourContainsDerived flavour- = do { result <- touchabilityTest Derived lhs_tv rhs- ; return $ case result of- Untouchable -> False- _ -> True }- | otherwise- = return False+ final_check = case flavour of+ Given -> return True+ Wanted -> do { result <- touchabilityTest Wanted lhs_tv rhs+ ; return $ case result of+ Untouchable -> False+ _ -> True } -- This could be considerably more efficient. See Detail (5) of Note. go :: TcType -> TcS ReductionN@@ -2349,10 +1979,10 @@ ; return $ mkReflRedn Nominal new_ty } -- Why reflexive? See Detail (4) of the Note - _derived_or_wd ->+ Wanted -> do { new_tv <- wrapTcS (TcM.newFlexiTyVar fun_app_kind) ; let new_ty = mkTyVarTy new_tv- ; co <- emitNewWantedEq new_loc Nominal new_ty fun_app+ ; co <- emitNewWantedEq new_loc (ctEvRewriters ev) Nominal new_ty fun_app ; return $ mkReduction (mkSymCo co) new_ty } -- See Detail (7) of the Note
compiler/GHC/Tc/Solver/Rewrite.hs view
@@ -5,7 +5,7 @@ {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Tc.Solver.Rewrite(- rewrite, rewriteKind, rewriteArgsNom,+ rewrite, rewriteArgsNom, rewriteType ) where @@ -34,15 +34,14 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Tc.Solver.Monad as TcS-import GHC.Tc.Solver.Types+ import GHC.Utils.Misc import GHC.Data.Maybe import GHC.Exts (oneShot) import Control.Monad-import GHC.Utils.Monad ( zipWith3M )-import Data.List.NonEmpty ( NonEmpty(..) ) import Control.Applicative (liftA3) import GHC.Builtin.Types.Prim (tYPETyCon)+import Data.List ( find ) {- ************************************************************************@@ -82,18 +81,23 @@ -- convenient wrapper when you have a CtEvidence describing -- the rewriting operation-runRewriteCtEv :: CtEvidence -> RewriteM a -> TcS a+runRewriteCtEv :: CtEvidence -> RewriteM a -> TcS (a, RewriterSet) runRewriteCtEv ev = runRewrite (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev) -- Run thing_inside (which does the rewriting)-runRewrite :: CtLoc -> CtFlavour -> EqRel -> RewriteM a -> TcS a+-- Also returns the set of Wanteds which rewrote a Wanted;+-- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint+runRewrite :: CtLoc -> CtFlavour -> EqRel -> RewriteM a -> TcS (a, RewriterSet) runRewrite loc flav eq_rel thing_inside- = runRewriteM thing_inside fmode- where- fmode = FE { fe_loc = loc- , fe_flavour = flav- , fe_eq_rel = eq_rel }+ = do { rewriters_ref <- newTcRef emptyRewriterSet+ ; let fmode = RE { re_loc = loc+ , re_flavour = flav+ , re_eq_rel = eq_rel+ , re_rewriters = rewriters_ref }+ ; res <- runRewriteM thing_inside fmode+ ; rewriters <- readTcRef rewriters_ref+ ; return (res, rewriters) } traceRewriteM :: String -> SDoc -> RewriteM () traceRewriteM herald doc = liftTcS $ traceTcS herald doc@@ -108,13 +112,13 @@ = mkRewriteM $ \env -> return (accessor env) getEqRel :: RewriteM EqRel-getEqRel = getRewriteEnvField fe_eq_rel+getEqRel = getRewriteEnvField re_eq_rel getRole :: RewriteM Role getRole = eqRelRole <$> getEqRel getFlavour :: RewriteM CtFlavour-getFlavour = getRewriteEnvField fe_flavour+getFlavour = getRewriteEnvField re_flavour getFlavourRole :: RewriteM CtFlavourRole getFlavourRole@@ -123,7 +127,7 @@ ; return (flavour, eq_rel) } getLoc :: RewriteM CtLoc-getLoc = getRewriteEnvField fe_loc+getLoc = getRewriteEnvField re_loc checkStackDepth :: Type -> RewriteM () checkStackDepth ty@@ -134,38 +138,32 @@ setEqRel :: EqRel -> RewriteM a -> RewriteM a setEqRel new_eq_rel thing_inside = mkRewriteM $ \env ->- if new_eq_rel == fe_eq_rel env+ if new_eq_rel == re_eq_rel env then runRewriteM thing_inside env- else runRewriteM thing_inside (env { fe_eq_rel = new_eq_rel })+ else runRewriteM thing_inside (env { re_eq_rel = new_eq_rel }) {-# INLINE setEqRel #-} --- | Make sure that rewriting actually produces a coercion (in other--- words, make sure our flavour is not Derived)--- Note [No derived kind equalities]-noBogusCoercions :: RewriteM a -> RewriteM a-noBogusCoercions thing_inside- = mkRewriteM $ \env ->- -- No new thunk is made if the flavour hasn't changed (note the bang).- let !env' = case fe_flavour env of- Derived -> env { fe_flavour = Wanted WDeriv }- _ -> env- in- runRewriteM thing_inside env'- bumpDepth :: RewriteM a -> RewriteM a bumpDepth (RewriteM thing_inside) = mkRewriteM $ \env -> do -- bumpDepth can be called a lot during rewriting so we force the -- new env to avoid accumulating thunks.- { let !env' = env { fe_loc = bumpCtLocDepth (fe_loc env) }+ { let !env' = env { re_loc = bumpCtLocDepth (re_loc env) } ; thing_inside env' } +-- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint+-- Precondition: the CtEvidence is a CtWanted of an equality+recordRewriter :: CtEvidence -> RewriteM ()+recordRewriter (CtWanted { ctev_dest = HoleDest hole })+ = RewriteM $ \env -> updTcRef (re_rewriters env) (`addRewriterSet` hole)+recordRewriter other = pprPanic "recordRewriter" (ppr other)+ {- Note [Rewriter EqRels] ~~~~~~~~~~~~~~~~~~~~~~~ When rewriting, we need to know which equality relation -- nominal or representation -- we should be respecting. The only difference is-that we rewrite variables by representational equalities when fe_eq_rel+that we rewrite variables by representational equalities when re_eq_rel is ReprEq, and that we unwrap newtypes when rewriting w.r.t. representational equality. @@ -203,14 +201,6 @@ canonicaliser will emit an insoluble, in which case we get a better error message anyway.) -Note [No derived kind equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A kind-level coercion can appear in types, via mkCastTy. So, whenever-we are generating a coercion in a dependent context (in other words,-in a kind) we need to make sure that our flavour is never Derived-(as Derived constraints have no evidence). The noBogusCoercions function-changes the flavour from Derived just for this purpose.- -} {- *********************************************************************@@ -221,32 +211,21 @@ -} -- | See Note [Rewriting].--- If (xi, co) <- rewrite mode ev ty, then co :: xi ~r ty+-- If (xi, co, rewriters) <- rewrite mode ev ty, then co :: xi ~r ty -- where r is the role in @ev@.+-- rewriters is the set of coercion holes that have been used to rewrite+-- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint rewrite :: CtEvidence -> TcType- -> TcS Reduction+ -> TcS (Reduction, RewriterSet) rewrite ev ty = do { traceTcS "rewrite {" (ppr ty)- ; redn <- runRewriteCtEv ev (rewrite_one ty)+ ; result@(redn, _) <- runRewriteCtEv ev (rewrite_one ty) ; traceTcS "rewrite }" (ppr $ reductionReducedType redn)- ; return redn }---- specialized to rewriting kinds: never Derived, always Nominal--- See Note [No derived kind equalities]--- See Note [Rewriting]-rewriteKind :: CtLoc -> CtFlavour -> TcType -> TcS ReductionN-rewriteKind loc flav ty- = do { traceTcS "rewriteKind {" (ppr flav <+> ppr ty)- ; let flav' = case flav of- Derived -> Wanted WDeriv -- the WDeriv/WOnly choice matters not- _ -> flav- ; redn <- runRewrite loc flav' NomEq (rewrite_one ty)- ; traceTcS "rewriteKind }" (ppr redn) -- the coercion inside the reduction is never a panic- ; return redn }+ ; return result } -- See Note [Rewriting] rewriteArgsNom :: CtEvidence -> TyCon -> [TcType]- -> TcS Reductions+ -> TcS (Reductions, RewriterSet) -- Externally-callable, hence runRewrite -- Rewrite a vector of types all at once; in fact they are -- always the arguments of type family or class, so@@ -255,15 +234,15 @@ -- The kind passed in is the kind of the type family or class, call it T -- The kind of T args must be constant (i.e. not depend on the args) ----- For Derived constraints the returned coercion may be undefined--- because rewriting may use a Derived equality ([D] a ~ ty)+-- Final return value returned which Wanteds rewrote another Wanted+-- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint rewriteArgsNom ev tc tys = do { traceTcS "rewrite_args {" (vcat (map ppr tys))- ; ArgsReductions redns@(Reductions _ tys') kind_co+ ; (ArgsReductions redns@(Reductions _ tys') kind_co, rewriters) <- runRewriteCtEv ev (rewrite_args_tc tc Nothing tys) ; massert (isReflMCo kind_co) ; traceTcS "rewrite }" (vcat (map ppr tys'))- ; return redns }+ ; return (redns, rewriters) } -- | Rewrite a type w.r.t. nominal equality. This is useful to rewrite -- a type w.r.t. any givens. It does not do type-family reduction. This@@ -271,10 +250,10 @@ -- only givens. rewriteType :: CtLoc -> TcType -> TcS TcType rewriteType loc ty- = do { redn <- runRewrite loc Given NomEq $- rewrite_one ty+ = do { (redn, _) <- runRewrite loc Given NomEq $+ rewrite_one ty -- use Given flavor so that it is rewritten- -- only w.r.t. Givens, never Wanteds/Deriveds+ -- only w.r.t. Givens, never Wanteds -- (Shouldn't matter, if only Givens are present -- anyway) ; return $ reductionReducedType redn }@@ -462,38 +441,20 @@ -> [Role] -> [Type] -> RewriteM ArgsReductions rewrite_args_slow binders inner_ki fvs roles tys--- Arguments used dependently must be rewritten with proper coercions, but--- we're not guaranteed to get a proper coercion when rewriting with the--- "Derived" flavour. So we must call noBogusCoercions when rewriting arguments--- corresponding to binders that are dependent. However, we might legitimately--- have *more* arguments than binders, in the case that the inner_ki is a variable--- that gets instantiated with a Π-type. We conservatively choose not to produce--- bogus coercions for these, too. Note that this might miss an opportunity for--- a Derived rewriting a Derived. The solution would be to generate evidence for--- Deriveds, thus avoiding this whole noBogusCoercions idea. See also--- Note [No derived kind equalities]- = do { rewritten_args <- zipWith3M rw (map isNamedBinder binders ++ repeat True)- roles tys- ; return $ simplifyArgsWorker binders inner_ki fvs roles rewritten_args }+ = do { rewritten_args <- zipWithM rw roles tys+ ; return (simplifyArgsWorker binders inner_ki fvs roles rewritten_args) } where {-# INLINE rw #-}- rw :: Bool -- must we ensure to produce a real coercion here?- -- see comment at top of function- -> Role -> Type -> RewriteM Reduction- rw True r ty = noBogusCoercions $ rw1 r ty- rw False r ty = rw1 r ty-- {-# INLINE rw1 #-}- rw1 :: Role -> Type -> RewriteM Reduction- rw1 Nominal ty+ rw :: Role -> Type -> RewriteM Reduction+ rw Nominal ty = setEqRel NomEq $ rewrite_one ty - rw1 Representational ty+ rw Representational ty = setEqRel ReprEq $ rewrite_one ty - rw1 Phantom ty+ rw Phantom ty -- See Note [Phantoms in the rewriter] = do { ty <- liftTcS $ zonkTcType ty ; return $ mkReflRedn Phantom ty }@@ -859,17 +820,13 @@ where reduced = mkTyConApp tc xis -- STEP 3: try the inerts- ; result2 <- liftTcS $ lookupFamAppInert tc xis ; flavour <- getFlavour+ ; result2 <- liftTcS $ lookupFamAppInert (`eqCanRewriteFR` (flavour, eq_rel)) tc xis ; case result2 of- { Just (redn, fr@(_, inert_eq_rel))-- | fr `eqCanRewriteFR` (flavour, eq_rel) ->- do { traceRewriteM "rewrite family application with inert" $- vcat [ ppr tc <+> ppr xis- , ppUnless (flavour == Derived) (ppr redn) ]- -- Deriveds have no evidence, so we can't print the reduction- ; finish True (homogenise downgraded_redn) }+ { Just (redn, (inert_flavour, inert_eq_rel))+ -> do { traceRewriteM "rewrite family application with inert"+ (ppr tc <+> ppr xis $$ ppr redn)+ ; finish (inert_flavour == Given) (homogenise downgraded_redn) } -- this will sometimes duplicate an inert in the cache, -- but avoiding doing so had no impact on performance, and -- it seems easier not to weed out that special case@@ -890,18 +847,17 @@ -- call this if the above attempts made progress. -- This recursively rewrites the result and then adds to the cache finish :: Bool -- add to the cache?+ -- Precondition: True ==> input coercion has+ -- no coercion holes -> Reduction -> RewriteM Reduction finish use_cache redn = do { -- rewrite the result: FINISH 1 final_redn <- rewrite_reduction redn ; eq_rel <- getEqRel- ; flavour <- getFlavour -- extend the cache: FINISH 2- ; when (use_cache && eq_rel == NomEq && flavour /= Derived) $+ ; when (use_cache && eq_rel == NomEq) $ -- the cache only wants Nominal eqs- -- and Wanteds can rewrite Deriveds; the cache- -- has only Givens liftTcS $ extendFamAppCache tc tys final_redn ; return final_redn } {-# INLINE finish #-}@@ -1034,31 +990,34 @@ rewrite_tyvar2 tv fr@(_, eq_rel) = do { ieqs <- liftTcS $ getInertEqs ; case lookupDVarEnv ieqs tv of- Just (EqualCtList (ct :| _)) -- If the first doesn't work,- -- the subsequent ones won't either- | CEqCan { cc_ev = ctev, cc_lhs = TyVarLHS tv+ Just equal_ct_list+ | Just ct <- find can_rewrite equal_ct_list+ , CEqCan { cc_ev = ctev, cc_lhs = TyVarLHS tv , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct- , let ct_fr = (ctEvFlavour ctev, ct_eq_rel)- , ct_fr `eqCanRewriteFR` fr -- This is THE key call of eqCanRewriteFR- -> do { traceRewriteM "Following inert tyvar"- (ppr tv <+>- equals <+>- ppr rhs_ty $$ ppr ctev)- ; let rewriting_co1 = ctEvCoercion ctev- rewriting_co = case (ct_eq_rel, eq_rel) of- (ReprEq, _rel) -> assert (_rel == ReprEq )- -- if this ASSERT fails, then+ -> do { let wrw = isWantedCt ct+ ; traceRewriteM "Following inert tyvar" $+ vcat [ ppr tv <+> equals <+> ppr rhs_ty+ , ppr ctev+ , text "wanted_rewrite_wanted:" <+> ppr wrw ]+ ; when wrw $ recordRewriter ctev++ ; let rewriting_co1 = ctEvCoercion ctev+ rewriting_co = case (ct_eq_rel, eq_rel) of+ (ReprEq, _rel) -> assert (_rel == ReprEq)+ -- if this assert fails, then -- eqCanRewriteFR answered incorrectly rewriting_co1 (NomEq, NomEq) -> rewriting_co1 (NomEq, ReprEq) -> mkSubCo rewriting_co1 - ; return $ RTRFollowed $ mkReduction rewriting_co rhs_ty }- -- NB: ct is Derived then fmode must be also, hence- -- we are not going to touch the returned coercion- -- so ctEvCoercion is fine.+ ; return $ RTRFollowed $ mkReduction rewriting_co rhs_ty } _other -> return RTRNotFollowed }++ where+ can_rewrite :: Ct -> Bool+ can_rewrite ct = ctFlavourRole ct `eqCanRewriteFR` fr+ -- This is THE key call of eqCanRewriteFR {- Note [An alternative story for the inert substitution]
compiler/GHC/Tc/TyCl.hs view
@@ -3224,11 +3224,6 @@ -- F c x y a :: Type -- Here the first arg of F should be the same as the third of C -- and the fourth arg of F should be the same as the first of C------ We emit /Derived/ constraints (a bit like fundeps) to encourage--- unification to happen, but without actually reporting errors.--- If, despite the efforts, corresponding positions do not match,--- checkConsistentFamInst will complain addConsistencyConstraints mb_clsinfo fam_app | InClsInst { ai_inst_env = inst_env } <- mb_clsinfo , Just (fam_tc, pats) <- tcSplitTyConApp_maybe fam_app@@ -3236,8 +3231,9 @@ | (fam_tc_tv, pat) <- tyConTyVars fam_tc `zip` pats , Just cls_ty <- [lookupVarEnv inst_env fam_tc_tv] ] ; traceTc "addConsistencyConstraints" (ppr eqs)- ; emitDerivedEqs AssocFamPatOrigin eqs }- -- Improve inference+ ; emitWantedEqs AssocFamPatOrigin eqs }+ -- Improve inference; these equalities will not produce errors.+ -- See Note [Constraints to ignore] in GHC.Tc.Errors -- Any mis-match is reports by checkConsistentFamInst | otherwise = return ()@@ -4350,7 +4346,9 @@ addErrCtxt (dataConCtxt [L (noAnnSrcSpan con_loc) con_name]) $ do { let tc_tvs = tyConTyVars tc res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)- orig_res_ty = dataConOrigResTy con+ arg_tys = dataConOrigArgTys con+ orig_res_ty = dataConOrigResTy con+ ; traceTc "checkValidDataCon" (vcat [ ppr con, ppr tc, ppr tc_tvs , ppr res_ty_tmpl <+> dcolon <+> ppr (tcTypeKind res_ty_tmpl)@@ -4387,15 +4385,20 @@ -- Reason: it's really the argument of an equality constraint ; checkValidMonoType orig_res_ty - -- If we are dealing with a newtype, we allow representation- -- polymorphism regardless of whether or not UnliftedNewtypes- -- is enabled. A later check in checkNewDataCon handles this,- -- producing a better error message than checkTypeHasFixedRuntimeRep would.+ -- Check for an escaping result kind+ -- See Note [Check for escaping result kind]+ ; checkEscapingKind con++ -- For /data/ types check that each argument has a fixed runtime rep+ -- If we are dealing with a /newtype/, we allow representation+ -- polymorphism regardless of whether or not UnliftedNewtypes+ -- is enabled. A later check in checkNewDataCon handles this,+ -- producing a better error message than checkTypeHasFixedRuntimeRep would.+ ; let check_rr = checkTypeHasFixedRuntimeRep FixedRuntimeRepDataConField ; unless (isNewTyCon tc) $- checkNoErrs $- mapM_ (checkTypeHasFixedRuntimeRep FixedRuntimeRepDataConField)- (map scaledThing $ dataConOrigArgTys con)- -- the checkNoErrs is to prevent a panic in isVanillaDataCon+ checkNoErrs $+ mapM_ (check_rr . scaledThing) arg_tys+ -- The checkNoErrs is to prevent a panic in isVanillaDataCon -- (called a a few lines down), which can fall over if there is a -- bang on a representation-polymorphic argument. This is #18534, -- typecheck/should_fail/T18534@@ -4489,9 +4492,9 @@ } where bang_opts = initBangOpts dflags- con_name = dataConName con- con_loc = nameSrcSpan con_name- ctxt = ConArgCtxt con_name+ con_name = dataConName con+ con_loc = nameSrcSpan con_name+ ctxt = ConArgCtxt con_name is_strict = \case NoSrcStrict -> bang_opt_strict_data bang_opts bang -> isSrcStrict bang@@ -4553,6 +4556,47 @@ ok_mult One = True ok_mult _ = False+++-- | Reject nullary data constructors where a type variables+-- would escape through the result kind+-- See Note [Check for escaping result kind]+checkEscapingKind :: DataCon -> TcM ()+checkEscapingKind data_con+ | null eq_spec, null theta, null arg_tys+ , let tau_kind = tcTypeKind res_ty+ , Nothing <- occCheckExpand (univ_tvs ++ ex_tvs) tau_kind+ -- Ensure that none of the tvs occur in the kind of the forall+ -- /after/ expanding type synonyms.+ -- See Note [Phantom type variables in kinds] in GHC.Core.Type+ = failWithTc $ TcRnForAllEscapeError (dataConWrapperType data_con) tau_kind+ | otherwise+ = return ()+ where+ (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty)+ = dataConFullSig data_con++{- Note [Check for escaping result kind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:+ type T :: TYPE (BoxedRep l)+ data T = MkT+This is not OK: we get+ MkT :: forall l. T @l :: TYPE (BoxedRep l)+which is ill-kinded.++For ordinary type signatures f :: blah, we make this check as part of kind-checking+the type signature; see Note [Escaping kind in type signatures] in GHC.Tc.Gen.HsType.+But for data constructors we check the type piecemeal, and there is no very+convenient place to do it. For example, note that it only applies for /nullary/+constructors. If we had+ data T = MkT Int+then the type of MkT would be MkT :: forall l. Int -> T @l, which is fine.++So we make the check in checkValidDataCon.++Historical note: we used to do the check in checkValidType (#20929 discusses).+-} ------------------------------- checkValidClass :: Class -> TcM ()
compiler/GHC/Tc/TyCl/Build.hs view
@@ -326,7 +326,7 @@ -- i.e. exactly one operation or superclass taken together -- (b) that value is of lifted type (which they always are, because -- we box equality superclasses)- -- See note [Class newtypes and equality predicates]+ -- See Note [Class newtypes and equality predicates] -- We treat the dictionary superclasses as ordinary arguments. -- That means that in the case of
compiler/GHC/Tc/TyCl/Instance.hs view
@@ -1951,8 +1951,9 @@ -- checking instance-sig <= class-meth-sig -- The instance-sig is the focus here; the class-meth-sig -- is fixed (#18036)+ ; let orig = InstanceSigOrigin sel_name sig_ty local_meth_ty ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $- tcSubTypeSigma ctxt sig_ty local_meth_ty+ tcSubTypeSigma orig ctxt sig_ty local_meth_ty ; return (sig_ty, hs_wrap) } ; inner_meth_name <- newName (nameOccName sel_name)
compiler/GHC/Tc/TyCl/PatSyn.hs view
@@ -316,7 +316,7 @@ So in mkProvEvidence we lift (a ~# b) to (a ~ b). Tiresome, and marginally less efficient, if the builder/martcher are not inlined. -See also Note [Lift equality constraints when quantifying] in GHC.Tc.Utils.TcType+See also Note [Lift equality constraints when quantifying] in GHC.Tc.Solver Note [Coercions that escape] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -474,7 +474,8 @@ -- Else the error message location is wherever tcCheckPat finished, -- namely the right-hand corner of the pattern do { arg_id <- tcLookupId arg_name- ; wrap <- tcSubTypeSigma GenSigCtxt+ ; wrap <- tcSubTypeSigma (OccurrenceOf (idName arg_id))+ GenSigCtxt (idType arg_id) (substTy subst arg_ty) -- Why do we need tcSubType here?
compiler/GHC/Tc/Utils/Backpack.hs view
@@ -146,7 +146,7 @@ tcg_fam_inst_env = emptyFamInstEnv, tcg_insts = [], tcg_fam_insts = [] } $ do- mapM_ check_inst sig_insts+ mapM_ check_inst (instEnvElts sig_insts) failIfErrsM where -- NB: the Names in sig_type_env are bogus. Let's say we have H.hsig@@ -156,7 +156,7 @@ sig_type_occ_env = mkOccEnv . map (\t -> (nameOccName (getName t), t)) $ nonDetNameEnvElts sig_type_env- dfun_names = map getName sig_insts+ dfun_names = map getName (instEnvElts sig_insts) check_export name -- Skip instances, we'll check them later -- TODO: Actually this should never happen, because DFuns are@@ -865,7 +865,7 @@ = (inst:insts, extendInstEnv inst_env inst) (insts, inst_env) = foldl' merge_inst (tcg_insts tcg_env, tcg_inst_env tcg_env)- (md_insts details)+ (instEnvElts $ md_insts details) -- This is a HACK to prevent calculateAvails from including imp_mod -- in the listing. We don't want it because a module is NOT -- supposed to include itself in its dep_orphs/dep_finsts. See #13214
compiler/GHC/Tc/Utils/Concrete.hs view
@@ -11,12 +11,13 @@ import GHC.Prelude -import GHC.Core.Coercion+import GHC.Core.Coercion ( multToCo )+import GHC.Core.Type ( isConcrete, typeKind ) import GHC.Core.TyCo.Rep import GHC.Tc.Utils.Monad-import GHC.Tc.Utils.TcType ( TcType, mkTyConApp )-import GHC.Tc.Utils.TcMType ( newCoercionHole, newFlexiTyVarTy )+import GHC.Tc.Utils.TcType ( mkTyConApp )+import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Constraint import GHC.Tc.Types.Evidence import GHC.Tc.Types.Origin ( CtOrigin(..), FRROrigin(..), WpFunOrigin(..) )@@ -26,8 +27,8 @@ import GHC.Types.Basic ( TypeOrKind(KindLevel) ) -import GHC.Core.Type ( isConcrete, typeKind ) + {- Note [Concrete overview] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Special predicates of the form `Concrete# ty` are used@@ -402,11 +403,6 @@ Examples: backpack/should_run/T13955.bkp, rep-poly/RepPolyBackpack2. -} --- | A coercion hole used to store evidence for `Concrete#` constraints.------ See Note [The Concrete mechanism].-type ConcreteHole = CoercionHole- -- | Evidence for a `Concrete#` constraint: -- essentially a 'ConcreteHole' (a coercion hole) that will be filled later, -- except:@@ -458,42 +454,32 @@ -- Create a new Wanted 'Concrete#' constraint and emit it. | otherwise -> do { loc <- getCtLocM (FixedRuntimeRepOrigin ty frrOrig) (Just KindLevel)- ; (hole, ct_ev) <- newConcretePrimWanted loc ki+ ; (hole, _, ct_ev) <- newConcretePrimWanted loc ki ; emitSimple $ mkNonCanonical ct_ev ; return $ ConcreteHoleEvidence hole } } where ki :: Kind ki = typeKind ty --- | Create a new (initially unfilled) coercion hole,--- to hold evidence for a @'Concrete#' (ty :: ki)@ constraint.-newConcreteHole :: Kind -- ^ Kind of the thing we want to ensure is concrete (e.g. 'runtimeRepTy')- -> Type -- ^ Thing we want to ensure is concrete (e.g. some 'RuntimeRep')- -> TcM ConcreteHole-newConcreteHole ki ty- = do { concrete_ty <- newFlexiTyVarTy ki- ; let co_ty = mkHeteroPrimEqPred ki ki ty concrete_ty- ; newCoercionHole co_ty }- -- | Create a new 'Concrete#' constraint.-newConcretePrimWanted :: CtLoc -> Type -> TcM (ConcreteHole, CtEvidence)+-- Returns the evidence, a metavariable which will be filled in with a+-- guaranteed-concrete type, and a Wanted CtEvidence+newConcretePrimWanted :: CtLoc -> Type -> TcM (ConcreteHole, TcType, CtEvidence) newConcretePrimWanted loc ty = do { let ki :: Kind ki = typeKind ty- ; hole <- newConcreteHole ki ty+ ; (hole, concrete_ty) <- newConcreteHole ki ty ; let wantedCtEv :: CtEvidence wantedCtEv = CtWanted { ctev_dest = HoleDest hole , ctev_pred = mkTyConApp concretePrimTyCon [ki, ty]- , ctev_nosh = WOnly -- WOnly, because Derived Concrete# constraints- -- aren't useful: solving a Concrete# constraint- -- can't cause any unification to take place.+ , ctev_rewriters = emptyRewriterSet , ctev_loc = loc }- ; return (hole, wantedCtEv) }+ ; return (hole, concrete_ty, wantedCtEv) } {-*********************************************************************** * *
compiler/GHC/Tc/Utils/Monad.hs view
@@ -58,7 +58,7 @@ getRdrEnvs, getImports, getFixityEnv, extendFixityEnv, getRecFieldEnv, getDeclaredDefaultTys,- addDependentFiles, getMnwib,+ addDependentFiles, -- * Error management getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, addLocMA, inGeneratedCode,@@ -116,7 +116,7 @@ emitNamedTypeHole, IsExtraConstraint(..), emitAnonTypeHole, -- * Template Haskell context- recordThUse, recordThSpliceUse,+ recordThUse, recordThSpliceUse, recordThNeededRuntimeDeps, keepAlive, getStage, getStageAndBindLevel, setStage, addModFinalizersWithLclEnv, @@ -136,7 +136,6 @@ initIfaceLoadModule, getIfModule, failIfM,- forkM_maybe, forkM, setImplicitEnvM, @@ -222,6 +221,8 @@ import qualified Data.Map as Map import GHC.Driver.Env.KnotVars+import GHC.Linker.Types+import GHC.Types.Unique.DFM {- ************************************************************************@@ -263,6 +264,7 @@ th_state_var <- newIORef Map.empty ; th_remote_state_var <- newIORef Nothing ; th_docs_var <- newIORef Map.empty ;+ th_needed_deps_var <- newIORef ([], emptyUDFM) ; next_wrapper_num <- newIORef emptyModuleEnv ; let { -- bangs to avoid leaking the env (#19356)@@ -311,6 +313,7 @@ tcg_ann_env = emptyAnnEnv, tcg_th_used = th_var, tcg_th_splice_used = th_splice_var,+ tcg_th_needed_deps = th_needed_deps_var, tcg_exports = [], tcg_imports = emptyImportAvails, tcg_used_gres = used_gre_var,@@ -963,11 +966,6 @@ -- Avoid clash with Name.getSrcLoc getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Strict.Nothing) } -getMnwib :: TcRn ModuleNameWithIsBoot-getMnwib = do- gbl_env <- getGblEnv- return $ GWIB (moduleName $ tcg_mod gbl_env) (hscSourceToIsBoot (tcg_src gbl_env))- -- See Note [Error contexts in generated code] inGeneratedCode :: TcRn Bool inGeneratedCode = tcl_in_gen_code <$> getLclEnv@@ -1142,7 +1140,7 @@ ----------------------- checkNoErrs :: TcM r -> TcM r -- (checkNoErrs m) succeeds iff m succeeds and generates no errors--- If m fails then (checkNoErrsTc m) fails.+-- If m fails then (checkNoErrs m) fails. -- If m succeeds, it checks whether m generated any errors messages -- (it might have recovered internally) -- If so, it fails too.@@ -1262,10 +1260,10 @@ getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc getCtLocM origin t_or_k = do { env <- getLclEnv- ; return (CtLoc { ctl_origin = origin- , ctl_env = env- , ctl_t_or_k = t_or_k- , ctl_depth = initialSubGoalDepth }) }+ ; return (CtLoc { ctl_origin = origin+ , ctl_env = env+ , ctl_t_or_k = t_or_k+ , ctl_depth = initialSubGoalDepth }) } setCtLocM :: CtLoc -> TcM a -> TcM a -- Set the SrcSpan and error context from the CtLoc@@ -2010,6 +2008,15 @@ recordThSpliceUse :: TcM () recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True } +recordThNeededRuntimeDeps :: [Linkable] -> PkgsLoaded -> TcM ()+recordThNeededRuntimeDeps new_links new_pkgs+ = do { env <- getGblEnv+ ; updTcRef (tcg_th_needed_deps env) $ \(needed_links, needed_pkgs) ->+ let links = new_links ++ needed_links+ !pkgs = plusUDFM needed_pkgs new_pkgs+ in (links, pkgs)+ }+ keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set keepAlive name = do { env <- getGblEnv@@ -2189,14 +2196,14 @@ -- | 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 throws an error if the computation fails -- -- It's used for lazily type-checking interface -- 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+-- See Note [Masking exceptions in forkM]+forkM :: SDoc -> IfL a -> IfL a+forkM doc thing_inside = unsafeInterleaveM $ uninterruptibleMaskM_ $ do { traceIf (text "Starting fork {" <+> doc) ; mb_res <- tryM $@@ -2204,11 +2211,11 @@ thing_inside ; case mb_res of Right r -> do { traceIf (text "} ending fork" <+> doc)- ; return (Just r) }+ ; return 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)+ -- happen when compiling interface signatures. whenDOptM Opt_D_dump_if_trace $ do logger <- getLogger let msg = hang (text "forkM failed:" <+> doc)@@ -2217,33 +2224,24 @@ MCFatal noSrcSpan $ withPprStyle defaultErrStyle msg- ; traceIf (text "} ending fork (badly)" <+> doc)- ; return Nothing }+ ; pgmError "Cannot continue after interface file error" } } -forkM :: SDoc -> IfL a -> IfL a-forkM doc thing_inside- = do { mb_res <- forkM_maybe doc thing_inside- ; return (case mb_res of- Nothing -> pgmError "Cannot continue after interface file error"- -- pprPanic "forkM" doc- Just r -> r) }- setImplicitEnvM :: TypeEnv -> IfL a -> IfL a setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl { if_implicits_env = Just tenv }) m {--Note [Masking exceptions in forkM_maybe]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Masking exceptions in forkM]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When using GHC-as-API it must be possible to interrupt snippets of code executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible by throwing an asynchronous interrupt to the GHC thread. However, there is a subtle problem: runStmt first typechecks the code before running it, and the exception might interrupt the type checker rather than the code. Moreover, the-typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and+typechecker might be inside an unsafeInterleaveIO (through forkM), and more importantly might be inside an exception handler inside that unsafeInterleaveIO. If that is the case, the exception handler will rethrow the asynchronous exception as a synchronous exception, and the exception will end
compiler/GHC/Tc/Utils/TcMType.hs view
@@ -3,7 +3,6 @@ {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}-{-# LANGUAGE LambdaCase #-} {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -37,9 +36,9 @@ -------------------------------- -- Creating new evidence variables newEvVar, newEvVars, newDict,- newWantedWithLoc, newWanted, newWanteds, cloneWanted, cloneWC,+ newWantedWithLoc, newWanted, newWanteds, cloneWanted, cloneWC, cloneWantedCtEv, emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars,- emitDerivedEqs,+ emitWantedEqs, newTcEvBinds, newNoTcEvBinds, addTcEvBind, emitNewExprHole, @@ -47,6 +46,8 @@ unpackCoercionHole, unpackCoercionHole_maybe, checkCoercionHole, + ConcreteHole, newConcreteHole,+ newImplication, --------------------------------@@ -97,6 +98,10 @@ ------------------------------ -- Representation polymorphism checkTypeHasFixedRuntimeRep,++ ------------------------------+ -- Other+ anyUnfilledCoercionHoles ) where import GHC.Prelude@@ -192,12 +197,15 @@ -- | Create a new Wanted constraint with the given 'CtLoc'. newWantedWithLoc :: CtLoc -> PredType -> TcM CtEvidence newWantedWithLoc loc pty- = do d <- if isEqPrimPred pty then HoleDest <$> newCoercionHole pty- else EvVarDest <$> newEvVar pty- return $ CtWanted { ctev_dest = d- , ctev_pred = pty- , ctev_nosh = WDeriv- , ctev_loc = loc }+ = do d <- case classifyPredType pty of+ EqPred {} -> HoleDest <$> newCoercionHole pty+ SpecialPred ConcretePrimPred ty ->+ HoleDest <$> (fst <$> newConcreteHole (typeKind ty) ty)+ _ -> EvVarDest <$> newEvVar pty+ return $ CtWanted { ctev_dest = d+ , ctev_pred = pty+ , ctev_loc = loc+ , ctev_rewriters = emptyRewriterSet } -- | Create a new Wanted constraint with the given 'CtOrigin', and -- location information taken from the 'TcM' environment.@@ -216,14 +224,21 @@ -- Cloning constraints ---------------------------------------------- -cloneWanted :: Ct -> TcM Ct-cloneWanted ct- | ev@(CtWanted { ctev_pred = pty, ctev_dest = HoleDest _ }) <- ctEvidence ct+cloneWantedCtEv :: CtEvidence -> TcM CtEvidence+cloneWantedCtEv ctev@(CtWanted { ctev_pred = pty, ctev_dest = HoleDest _ })+ | isEqPrimPred pty = do { co_hole <- newCoercionHole pty- ; return (mkNonCanonical (ev { ctev_dest = HoleDest co_hole })) }+ ; return (ctev { ctev_dest = HoleDest co_hole }) }+ | SpecialPred ConcretePrimPred ty <- classifyPredType pty+ = do { (co_hole, _) <- newConcreteHole (typeKind ty) ty+ ; return (ctev { ctev_dest = HoleDest co_hole }) } | otherwise- = return ct+ = pprPanic "cloneWantedCtEv" (ppr pty)+cloneWantedCtEv ctev = return ctev +cloneWanted :: Ct -> TcM Ct+cloneWanted ct = mkNonCanonical <$> cloneWantedCtEv (ctEvidence ct)+ cloneWC :: WantedConstraints -> TcM WantedConstraints -- Clone all the evidence bindings in -- a) the ic_bind field of any implications@@ -252,19 +267,13 @@ ; emitSimple $ mkNonCanonical ev ; return $ ctEvTerm ev } -emitDerivedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM ()--- Emit some new derived nominal equalities-emitDerivedEqs origin pairs+emitWantedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM ()+-- Emit some new wanted nominal equalities+emitWantedEqs origin pairs | null pairs = return () | otherwise- = do { loc <- getCtLocM origin Nothing- ; emitSimples (listToBag (map (mk_one loc) pairs)) }- where- mk_one loc (ty1, ty2)- = mkNonCanonical $- CtDerived { ctev_pred = mkPrimEqPred ty1 ty2- , ctev_loc = loc }+ = mapM_ (uncurry (emitWantedEq origin TypeLevel Nominal)) pairs -- | Emits a new equality constraint emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion@@ -272,8 +281,10 @@ = do { hole <- newCoercionHole pty ; loc <- getCtLocM origin (Just t_or_k) ; emitSimple $ mkNonCanonical $- CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole- , ctev_nosh = WDeriv, ctev_loc = loc }+ CtWanted { ctev_pred = pty+ , ctev_dest = HoleDest hole+ , ctev_loc = loc+ , ctev_rewriters = rewriterSetFromTypes [ty1, ty2] } ; return (HoleCo hole) } where pty = mkPrimEqPredRole role ty1 ty2@@ -284,10 +295,10 @@ emitWantedEvVar origin ty = do { new_cv <- newEvVar ty ; loc <- getCtLocM origin Nothing- ; let ctev = CtWanted { ctev_dest = EvVarDest new_cv- , ctev_pred = ty- , ctev_nosh = WDeriv- , ctev_loc = loc }+ ; let ctev = CtWanted { ctev_dest = EvVarDest new_cv+ , ctev_pred = ty+ , ctev_loc = loc+ , ctev_rewriters = emptyRewriterSet } ; emitSimple $ mkNonCanonical ctev ; return new_cv } @@ -302,7 +313,7 @@ ; ref <- newTcRef (pprPanic "unfilled unbound-variable evidence" (ppr u)) ; let her = HER ref ty u - ; loc <- getCtLocM (ExprHoleOrigin occ) (Just TypeLevel)+ ; loc <- getCtLocM (ExprHoleOrigin (Just occ)) (Just TypeLevel) ; let hole = Hole { hole_sort = ExprHole her , hole_occ = occ@@ -353,7 +364,7 @@ newCoercionHole :: TcPredType -> TcM CoercionHole newCoercionHole pred_ty = do { co_var <- newEvVar pred_ty- ; traceTc "New coercion hole:" (ppr co_var)+ ; traceTc "New coercion hole:" (ppr co_var <+> dcolon <+> ppr pred_ty) ; ref <- newMutVar Nothing ; return $ CoercionHole { ch_co_var = co_var, ch_ref = ref } } @@ -411,6 +422,24 @@ | otherwise = False +-- | A coercion hole used to store evidence for `Concrete#` constraints.+--+-- See Note [The Concrete mechanism].+type ConcreteHole = CoercionHole++-- | Create a new (initially unfilled) coercion hole,+-- to hold evidence for a @'Concrete#' (ty :: ki)@ constraint.+newConcreteHole :: Kind -- ^ Kind of the thing we want to ensure is concrete (e.g. 'runtimeRepTy')+ -> Type -- ^ Thing we want to ensure is concrete (e.g. some 'RuntimeRep')+ -> TcM (ConcreteHole, TcType)+ -- ^ where to put the evidence, and a metavariable to store+ -- the concrete type+newConcreteHole ki ty+ = do { concrete_ty <- newFlexiTyVarTy ki+ ; let co_ty = mkHeteroPrimEqPred ki ki ty concrete_ty+ ; hole <- newCoercionHole co_ty+ ; return (hole, concrete_ty) }+ {- ********************************************************************** * ExpType functions@@ -1971,7 +2000,7 @@ ; return final_tv } where check_empty tv -- [Sept 04] Check for non-empty.- = when debugIsOn $ -- See note [Silly Type Synonym]+ = when debugIsOn $ -- See Note [Silly Type Synonyms] do { cts <- readMetaTyVar tv ; case cts of Flexi -> return ()@@ -2257,7 +2286,7 @@ * So we get a dict binding for Num (C d a), which is zonked to give a = ()- [Note Sept 04: now that we are zonking quantified type variables+ Note (Sept 04): now that we are zonking quantified type variables on construction, the 'a' will be frozen as a regular tyvar on quantification, so the floated dict will still have type (C d a). Which renders this whole note moot; happily!]@@ -2465,14 +2494,11 @@ zonkSkolemInfoAnon skol_info = return skol_info {--%************************************************************************-%* *-\subsection{Zonking -- the main work-horses: zonkTcType, zonkTcTyVar}+************************************************************************ * *-* For internal use only! *+ Zonking -- the main work-horses: zonkTcType, zonkTcTyVar * * ************************************************************************- -} -- For unbound, mutable tyvars, zonkType uses the function given to it@@ -2620,13 +2646,21 @@ ; return (env3, KindEqOrigin ty1' ty2' orig' t_or_k) } zonkTidyOrigin env (FunDepOrigin1 p1 o1 l1 p2 o2 l2) = do { (env1, p1') <- zonkTidyTcType env p1- ; (env2, p2') <- zonkTidyTcType env1 p2- ; return (env2, FunDepOrigin1 p1' o1 l1 p2' o2 l2) }+ ; (env2, o1') <- zonkTidyOrigin env1 o1+ ; (env3, p2') <- zonkTidyTcType env2 p2+ ; (env4, o2') <- zonkTidyOrigin env3 o2+ ; return (env4, FunDepOrigin1 p1' o1' l1 p2' o2' l2) } zonkTidyOrigin env (FunDepOrigin2 p1 o1 p2 l2) = do { (env1, p1') <- zonkTidyTcType env p1 ; (env2, p2') <- zonkTidyTcType env1 p2 ; (env3, o1') <- zonkTidyOrigin env2 o1 ; return (env3, FunDepOrigin2 p1' o1' p2' l2) }+zonkTidyOrigin env (InjTFOrigin1 pred1 orig1 loc1 pred2 orig2 loc2)+ = do { (env1, pred1') <- zonkTidyTcType env pred1+ ; (env2, orig1') <- zonkTidyOrigin env1 orig1+ ; (env3, pred2') <- zonkTidyTcType env2 pred2+ ; (env4, orig2') <- zonkTidyOrigin env3 orig2+ ; return (env4, InjTFOrigin1 pred1' orig1' loc1 pred2' orig2' loc2) } zonkTidyOrigin env (CycleBreakerOrigin orig) = do { (env1, orig') <- zonkTidyOrigin env orig ; return (env1, CycleBreakerOrigin orig') }@@ -2636,6 +2670,10 @@ zonkTidyOrigin env (FixedRuntimeRepOrigin ty frr_orig) = do { (env1, ty') <- zonkTidyTcType env ty ; return (env1, FixedRuntimeRepOrigin ty' frr_orig)}+zonkTidyOrigin env (WantedSuperclassOrigin pty orig)+ = do { (env1, pty') <- zonkTidyTcType env pty+ ; (env2, orig') <- zonkTidyOrigin env1 orig+ ; return (env2, WantedSuperclassOrigin pty' orig') } zonkTidyOrigin env orig = return (env, orig) zonkTidyOrigins :: TidyEnv -> [CtOrigin] -> TcM (TidyEnv, [CtOrigin])@@ -2644,13 +2682,14 @@ ---------------- tidyCt :: TidyEnv -> Ct -> Ct -- Used only in error reporting-tidyCt env ct- = ct { cc_ev = tidy_ev (ctEvidence ct) }- where- tidy_ev :: CtEvidence -> CtEvidence+tidyCt env ct = ct { cc_ev = tidyCtEvidence env (ctEvidence ct) }++tidyCtEvidence :: TidyEnv -> CtEvidence -> CtEvidence -- NB: we do not tidy the ctev_evar field because we don't -- show it in error messages- tidy_ev ctev = ctev { ctev_pred = tidyType env (ctev_pred ctev) }+tidyCtEvidence env ctev = ctev { ctev_pred = tidyType env ty }+ where+ ty = ctev_pred ctev tidyHole :: TidyEnv -> Hole -> Hole tidyHole env h@(Hole { hole_ty = ty }) = h { hole_ty = tidyType env ty }@@ -2728,3 +2767,49 @@ ] ; failWithTcM (env, msg) }++{-+************************************************************************+* *+ Checking for coercion holes+* *+************************************************************************+-}++-- | Check whether any coercion hole in a RewriterSet is still unsolved.+-- Does this by recursively looking through filled coercion holes until+-- one is found that is not yet filled in, at which point this aborts.+anyUnfilledCoercionHoles :: RewriterSet -> TcM Bool+anyUnfilledCoercionHoles (RewriterSet set)+ = nonDetStrictFoldUniqSet go (return False) set+ -- this does not introduce non-determinism, because the only+ -- monadic action is to read, and the combining function is+ -- commutative+ where+ go :: CoercionHole -> TcM Bool -> TcM Bool+ go hole m_acc = m_acc <||> check_hole hole++ check_hole :: CoercionHole -> TcM Bool+ check_hole hole = do { m_co <- unpackCoercionHole_maybe hole+ ; case m_co of+ Nothing -> return True -- unfilled hole+ Just co -> unUCHM (check_co co) }++ check_ty :: Type -> UnfilledCoercionHoleMonoid+ check_co :: Coercion -> UnfilledCoercionHoleMonoid+ (check_ty, _, check_co, _) = foldTyCo folder ()++ folder :: TyCoFolder () UnfilledCoercionHoleMonoid+ folder = TyCoFolder { tcf_view = noView+ , tcf_tyvar = \ _ tv -> check_ty (tyVarKind tv)+ , tcf_covar = \ _ cv -> check_ty (varType cv)+ , tcf_hole = \ _ -> UCHM . check_hole+ , tcf_tycobinder = \ _ _ _ -> () }++newtype UnfilledCoercionHoleMonoid = UCHM { unUCHM :: TcM Bool }++instance Semigroup UnfilledCoercionHoleMonoid where+ UCHM l <> UCHM r = UCHM (l <||> r)++instance Monoid UnfilledCoercionHoleMonoid where+ mempty = UCHM (return False)
compiler/GHC/Tc/Utils/Unify.hs view
@@ -556,8 +556,7 @@ -- If wrap = tc_sub_type_et t1 t2 -- => wrap :: t1 ~> t2 tcSubTypePat inst_orig ctxt (Check ty_actual) ty_expected- = do { dflags <- getDynFlags- ; tc_sub_type dflags unifyTypeET inst_orig ctxt ty_actual ty_expected }+ = tc_sub_type unifyTypeET inst_orig ctxt ty_actual ty_expected tcSubTypePat _ _ (Infer inf_res) ty_expected = do { co <- fillInferResult ty_expected inf_res@@ -584,9 +583,8 @@ -> TcM HsWrapper tcSubTypeNC inst_orig ctxt m_thing ty_actual res_ty = case res_ty of- Check ty_expected -> do { dflags <- getDynFlags- ; tc_sub_type dflags (unifyType m_thing) inst_orig ctxt- ty_actual ty_expected }+ Check ty_expected -> tc_sub_type (unifyType m_thing) inst_orig ctxt+ ty_actual ty_expected Infer inf_res -> do { (wrap, rho) <- topInstantiate inst_orig ty_actual -- See Note [Instantiation of InferResult]@@ -631,22 +629,18 @@ -} ----------------tcSubTypeSigma :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper+tcSubTypeSigma :: CtOrigin -- where did the actual type arise / why are we+ -- doing this subtype check?+ -> UserTypeCtxt -- where did the expected type arise?+ -> TcSigmaType -> TcSigmaType -> TcM HsWrapper -- External entry point, but no ExpTypes on either side -- Checks that actual <= expected -- Returns HsWrapper :: actual ~ expected-tcSubTypeSigma ctxt ty_actual ty_expected- = do { dflags <- getDynFlags- ; tc_sub_type dflags (unifyType Nothing) eq_orig ctxt ty_actual ty_expected }- where- eq_orig = TypeEqOrigin { uo_actual = ty_actual- , uo_expected = ty_expected- , uo_thing = Nothing- , uo_visible = True }+tcSubTypeSigma orig ctxt ty_actual ty_expected+ = tc_sub_type (unifyType Nothing) orig ctxt ty_actual ty_expected ----------------tc_sub_type :: DynFlags- -> (TcType -> TcType -> TcM TcCoercionN) -- How to unify+tc_sub_type :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify -> CtOrigin -- Used when instantiating -> UserTypeCtxt -- Used when skolemising -> TcSigmaType -- Actual; a sigma-type@@ -655,7 +649,7 @@ -- Checks that actual_ty is more polymorphic than expected_ty -- If wrap = tc_sub_type t1 t2 -- => wrap :: t1 ~> t2-tc_sub_type dflags unify inst_orig ctxt ty_actual ty_expected+tc_sub_type unify inst_orig ctxt ty_actual ty_expected | definitely_poly ty_expected -- See Note [Don't skolemise unnecessarily] , not (possibly_poly ty_actual) = do { traceTc "tc_sub_type (drop to equality)" $@@ -683,7 +677,7 @@ | (tvs, theta, tau) <- tcSplitSigmaTy ty , (tv:_) <- tvs , null theta- , checkTyVarEq dflags tv tau `cterHasProblem` cteInsolubleOccurs+ , checkTyVarEq tv tau `cterHasProblem` cteInsolubleOccurs = True | otherwise = False@@ -1067,7 +1061,7 @@ can yield /very/ confusing error messages, because we can get [W] C Int b1 -- from f_blah [W] C Int b2 -- from g_blan- and fundpes can yield [D] b1 ~ b2, even though the two functions have+ and fundpes can yield [W] b1 ~ b2, even though the two functions have literally nothing to do with each other. #14185 is an example. Building an implication keeps them separate. -}@@ -1447,15 +1441,14 @@ -> TcTauType -- Type 2, zonked -> TcM Coercion uUnfilledVar2 origin t_or_k swapped tv1 ty2- = do { dflags <- getDynFlags- ; cur_lvl <- getTcLevel- ; go dflags cur_lvl }+ = do { cur_lvl <- getTcLevel+ ; go cur_lvl } where- go dflags cur_lvl+ go cur_lvl | isTouchableMetaTyVar cur_lvl tv1 -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles , canSolveByUnification (metaTyVarInfo tv1) ty2- , cterHasNoProblem (checkTyVarEq dflags tv1 ty2)+ , cterHasNoProblem (checkTyVarEq tv1 ty2) -- See Note [Prevent unification with type families] = do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2) (tyVarKind tv1) ; traceTc "uUnfilledVar2 ok" $@@ -1471,7 +1464,8 @@ ; return (mkTcNomReflCo ty2) } else defer } -- This cannot be solved now. See GHC.Tc.Solver.Canonical- -- Note [Equalities with incompatible kinds]+ -- Note [Equalities with incompatible kinds] for how+ -- this will be dealt with in the solver | otherwise = do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr ty2)@@ -1485,14 +1479,20 @@ defer = unSwap swapped (uType_defer t_or_k origin) ty1 ty2 -canSolveByUnification :: MetaInfo -> TcType -> Bool--- See Note [Unification preconditions, (TYVAR-TV)]+-- | Checks (TYVAR-TV) and (COERCION-HOLE) of Note [Unification preconditions];+-- returns True if these conditions are satisfied. But see the Note for other+-- preconditions, too.+canSolveByUnification :: MetaInfo -> TcType -- zonked+ -> Bool+canSolveByUnification _ xi+ | hasCoercionHoleTy xi -- (COERCION-HOLE) check+ = False canSolveByUnification info xi = case info of CycleBreakerTv -> False TyVarTv -> case tcGetTyVar_maybe xi of Nothing -> False- Just tv -> case tcTyVarDetails tv of+ Just tv -> case tcTyVarDetails tv of -- (TYVAR-TV) wrinkle MetaTv { mtv_info = info } -> case info of TyVarTv -> True@@ -1552,7 +1552,7 @@ This note only applied to /homogeneous/ equalities, in which both sides have the same kind. -There are three reasons not to unify:+There are four reasons not to unify: 1. (SKOL-ESC) Skolem-escape Consider the constraint@@ -1590,9 +1590,23 @@ * CycleBreakerTv: never unified, except by restoreTyVarCycles. +4. (COERCION-HOLE) Confusing coercion holes+ Suppose our equality is+ (alpha :: k) ~ (Int |> {co})+ where co :: Type ~ k is an unsolved wanted. Note that this+ equality is homogeneous; both sides have kind k. Unifying here+ is sensible, but it can lead to very confusing error messages.+ It's very much like a Wanted rewriting a Wanted. Even worse,+ unifying a variable essentially turns an equality into a Given,+ and so we could not use the tracking mechansim in+ Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint.+ We thus simply do not unify in this case. -Needless to say, all three have wrinkles:+ This is expanded as Wrinkle (2) in Note [Equalities with incompatible kinds]+ in GHC.Tc.Solver.Canonical. +Needless to say, all there are wrinkles:+ * (SKOL-ESC) Promotion. Given alpha[n] ~ ty, what if beta[k] is free in 'ty', where beta is a unification variable, and k>n? 'beta' stands for a monotype, and since it is part of a level-n type@@ -1653,7 +1667,7 @@ Generally speaking we always try to put a MetaTv on the left in preference to SkolemTv or RuntimeUnkTv: a) Because the MetaTv may be touchable and can be unified- b) Even if it's not touchable, GHC.Tc.Solver.floatEqualities+ b) Even if it's not touchable, GHC.Tc.Solver.floatConstraints looks for meta tyvars on the left Tie-breaking rules for MetaTvs:@@ -1909,23 +1923,22 @@ ---------------- {-# NOINLINE checkTyVarEq #-} -- checkTyVarEq becomes big after the `inline` fires-checkTyVarEq :: DynFlags -> TcTyVar -> TcType -> CheckTyEqResult-checkTyVarEq dflags tv ty- = inline checkTypeEq dflags (TyVarLHS tv) ty+checkTyVarEq :: TcTyVar -> TcType -> CheckTyEqResult+checkTyVarEq tv ty+ = inline checkTypeEq (TyVarLHS tv) ty -- inline checkTypeEq so that the `case`s over the CanEqLHS get blasted away {-# NOINLINE checkTyFamEq #-} -- checkTyFamEq becomes big after the `inline` fires-checkTyFamEq :: DynFlags- -> TyCon -- type function+checkTyFamEq :: TyCon -- type function -> [TcType] -- args, exactly saturated -> TcType -- RHS -> CheckTyEqResult -- always drops cteTypeFamily-checkTyFamEq dflags fun_tc fun_args ty- = inline checkTypeEq dflags (TyFamLHS fun_tc fun_args) ty+checkTyFamEq fun_tc fun_args ty+ = inline checkTypeEq (TyFamLHS fun_tc fun_args) ty `cterRemoveProblem` cteTypeFamily -- inline checkTypeEq so that the `case`s over the CanEqLHS get blasted away -checkTypeEq :: DynFlags -> CanEqLHS -> TcType -> CheckTyEqResult+checkTypeEq :: CanEqLHS -> TcType -> CheckTyEqResult -- If cteHasNoProblem (checkTypeEq dflags lhs rhs), then lhs ~ rhs -- is a canonical CEqCan. --@@ -1933,8 +1946,7 @@ -- (a) a forall type (forall a. blah) -- (b) a predicate type (c => ty) -- (c) a type family; see Note [Prevent unification with type families]--- (d) a blocking coercion hole--- (e) an occurrence of the LHS (occurs check)+-- (d) an occurrence of the LHS (occurs check) -- -- Note that an occurs-check does not mean "definite error". For example -- type family F a@@ -1945,20 +1957,18 @@ -- certainly can't unify b0 := F b0 -- -- For (a), (b), and (c) we check only the top level of the type, NOT--- inside the kinds of variables it mentions. For (d) we look deeply--- in coercions when the LHS is a tyvar (but skip coercions for type family--- LHSs), and for (e) see Note [CEqCan occurs check] in GHC.Tc.Types.Constraint.+-- inside the kinds of variables it mentions, and for (d) see+-- Note [CEqCan occurs check] in GHC.Tc.Types.Constraint. -- -- checkTypeEq is called from -- * checkTyFamEq, checkTyVarEq (which inline it to specialise away the -- case-analysis on 'lhs') -- * checkEqCanLHSFinish, which does not know the form of 'lhs'-checkTypeEq dflags lhs ty+checkTypeEq lhs ty = go ty where impredicative = cteProblem cteImpredicative type_family = cteProblem cteTypeFamily- hole_blocker = cteProblem cteHoleBlocker insoluble_occurs = cteProblem cteInsolubleOccurs soluble_occurs = cteProblem cteSolubleOccurs @@ -2029,21 +2039,11 @@ -- inferred go_co co | TyVarLHS tv <- lhs , tv `elemVarSet` tyCoVarsOfCo co- = soluble_occurs S.<> maybe_hole_blocker+ = soluble_occurs -- Don't check coercions for type families; see commentary at top of function | otherwise- = maybe_hole_blocker- where- -- See GHC.Tc.Solver.Canonical Note [Equalities with incompatible kinds]- -- Wrinkle (2) about this case in general, Wrinkle (4b) about the check for- -- deferred type errors- maybe_hole_blocker | not (gopt Opt_DeferTypeErrors dflags)- , hasCoercionHoleCo co- = hole_blocker-- | otherwise- = cteOK+ = cteOK check_tc :: TyCon -> CheckTyEqResult check_tc
compiler/GHC/Tc/Utils/Zonk.hs view
@@ -68,7 +68,6 @@ import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Panic.Plain-import GHC.Utils.Constants (debugIsOn) import GHC.Core.Multiplicity import GHC.Core@@ -511,14 +510,14 @@ new_binds <- mapM (wrapLocMA zonk_ip_bind) binds let env1 = extendIdZonkEnvRec env- [ n | (L _ (IPBind _ (Right n) _)) <- new_binds]+ [ n | (L _ (IPBind n _ _)) <- new_binds] (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds)) where- zonk_ip_bind (IPBind x n e)- = do n' <- mapIPNameTc (zonkIdBndr env) n+ zonk_ip_bind (IPBind dict_id n e)+ = do dict_id' <- zonkIdBndr env dict_id e' <- zonkLExpr env e- return (IPBind x n' e')+ return (IPBind dict_id' n e') --------------------------------------------- zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (ZonkEnv, LHsBinds GhcTc)@@ -872,7 +871,7 @@ , rcon_flds = new_rbinds }) } -- Record updates via dot syntax are replaced by desugared expressions--- in the renamer. See Note [Rebindable Syntax and HsExpansion]. This+-- in the renamer. See Note [Rebindable syntax and HsExpansion]. This -- is why we match on 'rupd_flds = Left rbinds' here and panic otherwise. zonkExpr env (RecordUpd { rupd_flds = Left rbinds , rupd_expr = expr@@ -1318,13 +1317,6 @@ ; return (L l (fld { hfbLHS = fmap ambiguousFieldOcc new_id , hfbRHS = new_expr })) } ---------------------------------------------------------------------------mapIPNameTc :: (a -> TcM b) -> Either (LocatedAn NoEpAnns HsIPName) a- -> TcM (Either (LocatedAn NoEpAnns HsIPName) b)-mapIPNameTc _ (Left x) = return (Left x)-mapIPNameTc f (Right x) = do r <- f x- return (Right r)- {- ************************************************************************ * *@@ -1833,6 +1825,13 @@ SkolemiseFlexi -> return (mkTyVarTy (mkTyVar name zonked_kind)) DefaultFlexi+ -- Normally, RuntimeRep variables are defaulted in TcMType.defaultTyVar+ -- But that sees only type variables that appear in, say, an inferred type+ -- Defaulting here in the zonker is needed to catch e.g.+ -- y :: Bool+ -- y = (\x -> True) undefined+ -- We need *some* known RuntimeRep for the x and undefined, but no one+ -- will choose it until we get here, in the zonker. | isRuntimeRepTy zonked_kind -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv) ; return liftedRepTy }@@ -1877,11 +1876,6 @@ -- (undeferred) type errors. Originally, I put in a panic -- here, but that caused too many uses of `failIfErrsM`. Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr hole)- ; when debugIsOn $- whenNoErrs $- massertPpr False- (text "Type-correct unfilled coercion hole"- <+> ppr hole) ; cv' <- zonkCoVar cv ; return $ mkCoVarCo cv' } } -- This will be an out-of-scope variable, but keeping
compiler/GHC/Tc/Validity.hs view
@@ -45,6 +45,7 @@ import GHC.Tc.Types.Origin import GHC.Tc.Types.Rank import GHC.Tc.Errors.Types+import GHC.Types.Error -- others: import GHC.Iface.Type ( pprIfaceType, pprIfaceTypeApp )@@ -219,7 +220,7 @@ ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes ; (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $ captureConstraints $- tcSubTypeSigma ctxt ty ty+ tcSubTypeSigma (AmbiguityCheckOrigin ctxt) ctxt ty ty ; simplifyAmbiguityCheck ty wanted ; traceTc "Done ambiguity check for" (ppr ty) }@@ -345,6 +346,8 @@ checkValidType :: UserTypeCtxt -> Type -> TcM () -- Checks that a user-written type is valid for the given context -- Assumes argument is fully zonked+-- Assumes arugment is well-kinded;+-- that is, checkValidType doesn't need to do kind checking -- Not used for instance decls; checkValidInstance instead checkValidType ctxt ty = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (tcTypeKind ty))@@ -685,7 +688,8 @@ -- Rank is allowed rank for function args -- Rank 0 means no for-alls anywhere -check_type _ (TyVarTy _) = return ()+check_type _ (TyVarTy _)+ = return () check_type ve (AppTy ty1 ty2) = do { check_type ve ty1@@ -738,11 +742,11 @@ ; check_type (ve{ve_tidy_env = env'}) tau -- Allow foralls to right of arrow - ; checkEscapingKind env' tvbs' theta tau }+ } where (tvbs, phi) = tcSplitForAllTyVarBinders ty (theta, tau) = tcSplitPhiTy phi- (env', tvbs') = tidyTyCoVarBinders env tvbs+ (env', _) = tidyTyCoVarBinders env tvbs check_type (ve@ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt , ve_rank = rank })@@ -908,50 +912,6 @@ ; check_type (ve{ve_ctxt = ctxt', ve_rank = rank'}) ty } -------------------------------------------- | Reject type variables that would escape their escape through a kind.--- See @Note [Type variables escaping through kinds]@.-checkEscapingKind :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> TcM ()-checkEscapingKind env tvbs theta tau =- case occCheckExpand (binderVars tvbs) phi_kind of- -- Ensure that none of the tvs occur in the kind of the forall- -- /after/ expanding type synonyms.- -- See Note [Phantom type variables in kinds] in GHC.Core.Type- Nothing -> failWithTcM $ forAllEscapeErr env tvbs theta tau tau_kind- Just _ -> pure ()- where- tau_kind = tcTypeKind tau- phi_kind | null theta = tau_kind- | otherwise = liftedTypeKind- -- If there are any constraints, the kind is *. (#11405)--forAllEscapeErr :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> Kind- -> (TidyEnv, TcRnMessage)-forAllEscapeErr env tvbs theta tau tau_kind- -- NB: Don't tidy the sigma type since the tvbs were already tidied- -- previously, and re-tidying them will make the names of type- -- variables different from tau_kind.- = (env, TcRnForAllEscapeError (mkSigmaTy tvbs theta tau) (tidyType env tau_kind))--{--Note [Type variables escaping through kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider:-- type family T (r :: RuntimeRep) :: TYPE r- foo :: forall r. T r--Something smells funny about the type of `foo`. If you spell out the kind-explicitly, it becomes clearer from where the smell originates:-- foo :: ((forall r. T r) :: TYPE r)--The type variable `r` appears in the result kind, which escapes the scope of-its binding site! This is not desirable, so we establish a validity check-(`checkEscapingKind`) to catch any type variables that might escape through-kinds in this way.--}- checkConstraintsOK :: ValidityEnv -> ThetaType -> Type -> TcM () checkConstraintsOK ve theta ty | null theta = return ()@@ -1121,19 +1081,11 @@ -- is wrong. For user written signatures, it'll be rejected by kind-checking -- well before we get to validity checking. For inferred types we are careful -- to box such constraints in GHC.Tc.Utils.TcType.pickQuantifiablePreds, as described- -- in Note [Lift equality constraints when quantifying] in GHC.Tc.Utils.TcType+ -- in Note [Lift equality constraints when quantifying] in GHC.Tc.Solver ForAllPred _ theta head -> check_quant_pred env dflags ctxt pred theta head _ -> return () -check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TcM ()-check_eq_pred env dflags pred- = -- Equational constraints are valid in all contexts if type- -- families are permitted- checkTcM (xopt LangExt.TypeFamilies dflags- || xopt LangExt.GADTs dflags)- (env, TcRnIllegalEqualConstraints (tidyType env pred))- check_quant_pred :: TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> ThetaType -> PredType -> TcM () check_quant_pred env dflags ctxt pred theta head_pred@@ -1183,7 +1135,9 @@ check_class_pred env dflags ctxt pred cls tys | isEqPredClass cls -- (~) and (~~) are classified as classes, -- but here we want to treat them as equalities- = check_eq_pred env dflags pred+ = -- Equational constraints are valid in all contexts, and+ -- we do not need to check e.g. for FlexibleContexts here, so just do nothing+ return () | isIPClass cls = do { check_arity@@ -1427,21 +1381,24 @@ , not is_boot = failWithTc (TcRnAbstractClassInst clas) - -- For Typeable, don't complain about instances for- -- standalone deriving; they are no-ops, and we warn about- -- it in GHC.Tc.Deriv.deriveStandalone.+ -- Complain about hand-written instances of built-in classes+ -- Typeable, KnownNat, KnownSymbol, Coercible, HasField.++ -- Disallow hand-written Typeable instances, except that we+ -- allow a standalone deriving declaration: they are no-ops,+ -- and we warn about them in GHC.Tc.Deriv.deriveStandalone. | clas_nm == typeableClassName , not is_sig -- Note [Instances of built-in classes in signature files] , hand_written_bindings = failWithTc $ TcRnSpecialClassInst clas False - -- Handwritten instances of KnownNat/KnownSymbol- -- are forbidden outside of signature files (#12837)- | clas_nm `elem` [ knownNatClassName, knownSymbolClassName ]- , not is_sig+ -- Handwritten instances of KnownNat/KnownChar/KnownSymbol+ -- are forbidden outside of signature files (#12837).+ -- Derived instances are forbidden completely (#21087).+ | clas_nm `elem` [ knownNatClassName, knownSymbolClassName, knownCharClassName ]+ , (not is_sig && hand_written_bindings) || derived_instance -- Note [Instances of built-in classes in signature files]- , hand_written_bindings = failWithTc $ TcRnSpecialClassInst clas False -- For the most part we don't allow@@ -1459,6 +1416,10 @@ ; when (safeInferOn dflags) (recordUnsafeInfer emptyMessages) } | clas_nm == hasFieldClassName+ , not quantified_constraint+ -- Don't do any validity checking for HasField contexts+ -- inside quantified constraints (#20989): the validity checks+ -- only apply to user-written instances. = checkHasFieldInst clas cls_args | isCTupleClass clas@@ -1476,12 +1437,18 @@ ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args hand_written_bindings- = case ctxt of- InstDeclCtxt stand_alone -> not stand_alone- SpecInstCtxt -> False- DerivClauseCtxt -> False- SigmaCtxt -> False- _ -> True+ = case ctxt of+ InstDeclCtxt standalone -> not standalone+ SpecInstCtxt -> False+ DerivClauseCtxt -> False+ SigmaCtxt -> False+ _ -> True++ derived_instance+ = case ctxt of+ InstDeclCtxt standalone -> standalone+ DerivClauseCtxt -> True+ _ -> False check_h98_arg_shape = case ctxt of SpecInstCtxt -> False
compiler/GHC/ThToHs.hs view
@@ -910,7 +910,7 @@ cvtImplicitParamBind n e = do n' <- wrapL (ipName n) e' <- cvtl e- returnLA (IPBind noAnn (Left (reLocA n')) e')+ returnLA (IPBind noAnn (reLocA n') e') ------------------------------------------------------------------- -- Expressions@@ -1110,6 +1110,7 @@ boxity } {- Note [Operator association]+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~ We must be quite careful about adding parens: * Infix (UInfix ...) op arg Needs parens round the first arg * Infix (Infix ...) op arg Needs parens round the first arg
compiler/GHC/Unit/Finder.hs view
@@ -5,7 +5,6 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiWayIf #-} -- | Module finder module GHC.Unit.Finder (
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 0.20220201+version: 0.20220301 license: BSD3 license-file: LICENSE category: Development@@ -82,7 +82,7 @@ process >= 1 && < 1.7, rts, hpc == 0.6.*,- ghc-lib-parser == 0.20220201,+ ghc-lib-parser == 0.20220301, stm build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions:@@ -178,6 +178,7 @@ GHC.Core.Ppr, GHC.Core.Predicate, GHC.Core.Reduction,+ GHC.Core.RoughMap, GHC.Core.Rules, GHC.Core.Seq, GHC.Core.SimpleOpt,@@ -323,6 +324,7 @@ GHC.Settings, GHC.Settings.Config, GHC.Settings.Constants,+ GHC.Stg.InferTags.TagSig, GHC.Stg.Syntax, GHC.StgToCmm.Config, GHC.StgToCmm.Types,@@ -571,6 +573,7 @@ GHC.CmmToLlvm.Mangler GHC.CmmToLlvm.Ppr GHC.CmmToLlvm.Regs+ GHC.Core.LateCC GHC.Core.Opt.CSE GHC.Core.Opt.CallArity GHC.Core.Opt.CprAnal@@ -607,6 +610,10 @@ GHC.Driver.Config.CmmToLlvm GHC.Driver.Config.Finder GHC.Driver.Config.HsToCore+ GHC.Driver.Config.Stg.Debug+ GHC.Driver.Config.Stg.Lift+ GHC.Driver.Config.Stg.Pipeline+ GHC.Driver.Config.Stg.Ppr GHC.Driver.Config.StgToCmm GHC.Driver.GenerateCgIPEStub GHC.Driver.Main@@ -694,14 +701,19 @@ GHC.Stg.CSE GHC.Stg.Debug GHC.Stg.FVs+ GHC.Stg.InferTags+ GHC.Stg.InferTags.Rewrite+ GHC.Stg.InferTags.Types GHC.Stg.Lift GHC.Stg.Lift.Analysis+ GHC.Stg.Lift.Config GHC.Stg.Lift.Monad GHC.Stg.Lint GHC.Stg.Pipeline GHC.Stg.Stats GHC.Stg.Subst GHC.Stg.Unarise+ GHC.Stg.Utils GHC.StgToByteCode GHC.StgToCmm GHC.StgToCmm.ArgRep@@ -721,6 +733,7 @@ GHC.StgToCmm.Prim GHC.StgToCmm.Prof GHC.StgToCmm.Sequel+ GHC.StgToCmm.TagCheck GHC.StgToCmm.Ticky GHC.StgToCmm.Utils GHC.SysTools
ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs view
@@ -133,7 +133,7 @@ pc_ILDV_STATE_CREATE :: !Integer, pc_ILDV_STATE_USE :: !Integer, pc_USE_INLINE_SRT_FIELD :: !Bool- } deriving (Show,Read,Eq)+ } deriving (Show, Read, Eq, Ord) parseConstantsHeader :: FilePath -> IO PlatformConstants
ghc-lib/stage0/compiler/build/primop-docs.hs-incl view
@@ -206,7 +206,7 @@ , ("copyByteArrayToAddr#","Copy a range of the ByteArray\\# to the memory range starting at the Addr\\#.\n The ByteArray\\# and the memory region at Addr\\# must fully contain the\n specified ranges, but this is not checked. The Addr\\# must not point into the\n ByteArray\\# (e.g. if the ByteArray\\# were pinned), but this is not checked\n either.") , ("copyMutableByteArrayToAddr#","Copy a range of the MutableByteArray\\# to the memory range starting at the\n Addr\\#. The MutableByteArray\\# and the memory region at Addr\\# must fully\n contain the specified ranges, but this is not checked. The Addr\\# must not\n point into the MutableByteArray\\# (e.g. if the MutableByteArray\\# were\n pinned), but this is not checked either.") , ("copyAddrToByteArray#","Copy a memory range starting at the Addr\\# to the specified range in the\n MutableByteArray\\#. The memory region at Addr\\# and the ByteArray\\# must fully\n contain the specified ranges, but this is not checked. The Addr\\# must not\n point into the MutableByteArray\\# (e.g. if the MutableByteArray\\# were pinned),\n but this is not checked either.")- , ("setByteArray#","@setByteArray# ba off len c@ sets the byte range @[off, off+len]@ of\n the @MutableByteArray#@ to the byte @c@.")+ , ("setByteArray#","@setByteArray# ba off len c@ sets the byte range @[off, off+len)@ of\n the @MutableByteArray#@ to the byte @c@.") , ("atomicReadIntArray#","Given an array and an offset in machine words, read an element. The\n index is assumed to be in bounds. Implies a full memory barrier.") , ("atomicWriteIntArray#","Given an array and an offset in machine words, write an element. The\n index is assumed to be in bounds. Implies a full memory barrier.") , ("casIntArray#","Given an array, an offset in machine words, the expected old value, and\n the new value, perform an atomic compare and swap i.e. write the new\n value if the current value matches the provided old value. Returns\n the value of the element before the operation. Implies a full memory\n barrier.")
libraries/ghci/GHCi/TH.hs view
@@ -13,7 +13,7 @@ ) where {- Note [Remote Template Haskell]-+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is an overview of how TH works with -fexternal-interpreter. Initialisation